Originally Posted by
RasterImage
Wow, that's ace, so much neater than my effort. Brilliant.
Thank you! That makes me happy!
Originally Posted by
RasterImage
At the moment the spreadsheets just get saved to the Office default location, which works OK.
Note that the "default location" maybe is not the same with "current directory".
I recommends you to specify always the path of the desired location, even if this is not necessary. You can use the CurrentProject.Path or the Environ("APPDATA") to get a secured path in the user's system.
Originally Posted by
RasterImage
When I paste in your code I get the error "Sorry, we couldn't find Timesheet00007.xlsx. Is it possible it was moved, renamed or deleted?" at the line
Code:
Set wb = Exc.Workbooks.Open(PathFile)
I think that you faced this problem because of lack of explicitly specified directories where I am talking about. I believe that will run properly if you add the CurDir before the PathFile as seems below:
Code:
Set wb = Exc.Workbooks.Open(CurDir & "\" & PathFile)
Originally Posted by
RasterImage
I'd really like the user to be able to browse for a save location, but that's a problem for another day
I think that today is your lucky day:
Code:
Sub ExportTimesheet()
Dim Exc As Excel.Application
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Dim FD As FileDialog '<--Need a reference to Miscrosoft Office ##.0 Object Library
Dim strPath As String
Dim PathFile As String
Const strcDocName As String = "Timesheet" 'The query I want to trasfer to a spreadsheet
Const strcTableName As String = "Table1" 'The name of the table in spreadsheet
'Browse for the save location
Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
.AllowMultiSelect = False
.Title = "Select a folder for this timesheet"
If .Show Then
'Get the user's choise
strPath = .SelectedItems(1)
Else
'User did not select any folder
End If
End With
Set FD = Nothing
If Len(strPath) Then
'Build the file name of the spreadsheet
PathFile = strcDocName & Format(Me.txtTimesheetID, "00000") & ".xlsx"
'Build the full file name of the spreadsheet
PathFile = Replace(strPath & "\" & PathFile, "\\", "\")
'Export to the spreadsheet
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, strcDocName, PathFile, True
'Start Excel automation
Set Exc = New Excel.Application
On Error Resume Next
'Try to open the spreadsheet created
Set wb = Exc.Workbooks.Open(PathFile)
If Err = 0 Then
On Error Resume Next
'Try to make a pointer to the worksheet "Timesheet"
Set sh = wb.Worksheets(strcDocName)
If Err = 0 Then
With sh.ListObjects
On Error Resume Next
.Item("Table1").Unlist 'Remove the "Table1" table if exists
On Error GoTo ShowExcel 'In any case, we have a workbook open
'Try to add the table "Table1" and format it
With .Add(xlSrcRange, sh.Range("$A$1:$J$50"), , xlYes, , "TableStyleMedium2")
.Name = "Table1"
With .HeaderRowRange.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End With
End With
ShowExcel:
If Err <> 0 Then
'Just inform the user for the error
MsgBox Err.Description, vbExclamation, "Range formatting error(" & Err & ")"
End If
'Show spreadsheet created
Exc.Visible = True
Else
'Spreadsheet "Timesheet" not found!
MsgBox Err.Description, vbExclamation, "Pick spreadsheet error(" & Err & ")"
End If
Else
'Unable to open the workbook!
MsgBox Err.Description, vbExclamation, "Open workbook error(" & Err & ")"
End If
End If
Set sh = Nothing
Set wb = Nothing
Set Exc = Nothing
End Sub
Hope this helps.
Cheers,
John