Kennelbloke
Technical User
Hi Folks. I couldn't find an answer to my specific problem so came to the gurus
I export data from several qureis to the same Excel sheet using
[pre] DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qryTS_Shows", strFileName, True
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qryTS_Clubs", strFileName, True[/pre]
etc. There is about 10 all up
When importing back in (appending into a remote location database), I get a "Run-time error 3125". I've found some code (credits to the original author) that looks like it will do the job.
All of my tables are prefixed with "tbl" (tblShows, tblClubs etc) but the sheetnames are the query names. As you can see from the code below I'm stripping the first 6 chars off the front of the sheetname before storing it into the array. I get the error when reading the names from the array. If I leave the sheetnames as original it works fine but it creates new tables with the query names, not what I'm trying to do. I'm obviously missing something, I just can't work out what?
[pre]Private Sub GetExcelFile()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPassword As String
Dim signfile As Object
Set signfile = Application.FileDialog(3)
signfile.AllowMultiSelect = False
If signfile.Show Then
For i = 1 To signfile.SelectedItems.Count
strFileName = Filename(signfile.SelectedItems(i), sPath)
Next
Else
If IsNull(strFileName) Or strFileName = "" Then
strFileName = "" 'Return a blank to indicate no file selected
MsgBox "Import Cancelled"
Exit Sub
End If
End If
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = vbNullString
blnReadOnly = True ' open EXCEL file in read-only mode
' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strFileName, , blnReadOnly, , strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
colWorksheets.Add Trim(Right(objWorkbook.Worksheets(lngCount).Name, Len(objWorkbook.Worksheets(lngCount).Name) - 6))
Next lngCount
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
' Import the data from each worksheet into a separate table
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl" & colWorksheets(lngCount), strFileName, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount
' Delete the collection
Set colWorksheets = Nothing
' Uncomment out the next code step if you want to delete the EXCEL file after it's been imported
' Kill strPathFile
End Sub
[/pre]
I export data from several qureis to the same Excel sheet using
[pre] DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qryTS_Shows", strFileName, True
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qryTS_Clubs", strFileName, True[/pre]
etc. There is about 10 all up
When importing back in (appending into a remote location database), I get a "Run-time error 3125". I've found some code (credits to the original author) that looks like it will do the job.
All of my tables are prefixed with "tbl" (tblShows, tblClubs etc) but the sheetnames are the query names. As you can see from the code below I'm stripping the first 6 chars off the front of the sheetname before storing it into the array. I get the error when reading the names from the array. If I leave the sheetnames as original it works fine but it creates new tables with the query names, not what I'm trying to do. I'm obviously missing something, I just can't work out what?
[pre]Private Sub GetExcelFile()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPassword As String
Dim signfile As Object
Set signfile = Application.FileDialog(3)
signfile.AllowMultiSelect = False
If signfile.Show Then
For i = 1 To signfile.SelectedItems.Count
strFileName = Filename(signfile.SelectedItems(i), sPath)
Next
Else
If IsNull(strFileName) Or strFileName = "" Then
strFileName = "" 'Return a blank to indicate no file selected
MsgBox "Import Cancelled"
Exit Sub
End If
End If
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = True
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = vbNullString
blnReadOnly = True ' open EXCEL file in read-only mode
' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strFileName, , blnReadOnly, , strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
colWorksheets.Add Trim(Right(objWorkbook.Worksheets(lngCount).Name, Len(objWorkbook.Worksheets(lngCount).Name) - 6))
Next lngCount
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
' Import the data from each worksheet into a separate table
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "tbl" & colWorksheets(lngCount), strFileName, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount
' Delete the collection
Set colWorksheets = Nothing
' Uncomment out the next code step if you want to delete the EXCEL file after it's been imported
' Kill strPathFile
End Sub
[/pre]