K
KC_Cheer_Coach
I gleaned some code from the net and dropped in the specifics for my db. This
db is to hold data for quarterly reporting. I am trying to do the following:
Import specific spreadsheets from Excel 2007 workbooks based on information
entered on the main form and append the data to a single table in the
database. Each workbook has a different number of worksheets, each worksheet
has a different range of data, and each workbook has beginning and ending
worksheets that I do not need. There are a lot of things I have to define in
order for it to pull the correct file and this is working, but when it gets
to the section where it is to import data from the sheets to the table in
Access, it bugs out with msg "Run-time error '424': Object required". Can you
help? Here is the code and thanks in advance (KCCC):
Private Sub cmdImport_Click()
Dim blnHasFieldNames As Boolean, blnExcel As Boolean, blnReadOnly As Boolean
Dim lngCount As Long, lngStartSheet As Long, lngEndSheet As Long
Dim objExcel As Object, objWorkbook As Object, objRange As Object,
objWorksheet As Object
Dim colWorksheets As Collection
Dim intNoOfSheets As Integer
Dim strTable As String, strPassword As String, strWorksheetName As String
Dim strPath As String, strMainPath As String, strFilePath As String,
strAddPath As String, strMMM As String
Dim strRun As String, strExtension As String, strFilename As String
'Establish an Excel aapplication 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
'True if the first row in Excel worksheet has fieldnames
blnHasFieldNames = True
'Set the main part of the path (root)
strMainPath = "\\Share\Company\Fin\01\Service\"
'Set the middle part of the path
If Left$((Me.cboFilename), 2) = "CA" Then
strFilePath = "IV\CA Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "IP" Then
strFilePath = "IV\IP Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "PD" Then
strFilePath = "IV\PD Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "AA" Then
strFilePath = "IV\IP Verif\AA and MS\"
Else
If Left$((Me.cboFilename), 2) = "MS" Then
strFilePath = "IV\IP Verif\AA and MS\"
Else
If Left$((Me.cboFilename), 2) = "CT" Then
strFilePath = "PCV\CT Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "PR" Then
strFilePath = "PCV\PCVC\"
End If
End If
End If
End If
End If
End If
End If
'Set the specific date folders of the path
strAddPath = Left((Me.txtUsagePeriod), 4) & "\" &
Right$((Me.txtUsagePeriod), 2) & "_"
'Set the 3 char month name
If Right$((Me.txtUsagePeriod), 2) = "01" Then
strMMM = "Jan"
Else
If Right$((Me.txtUsagePeriod), 2) = "02" Then
strMMM = "Feb"
Else
If Right$((Me.txtUsagePeriod), 2) = "03" Then
strMMM = "Mar"
Else
If Right$((Me.txtUsagePeriod), 2) = "04" Then
strMMM = "Apr"
Else
If Right$((Me.txtUsagePeriod), 2) = "05" Then
strMMM = "May"
Else
If Right$((Me.txtUsagePeriod), 2) = "06" Then
strMMM = "Jun"
Else
If Right$((Me.txtUsagePeriod), 2) = "07" Then
strMMM = "Jul"
Else
If Right$((Me.txtUsagePeriod), 2) = "08" Then
strMMM = "Aug"
Else
If Right$((Me.txtUsagePeriod), 2) = "09" Then
strMMM = "Sep"
Else
If Right$((Me.txtUsagePeriod), 2) = "10" Then
strMMM = "Oct"
Else
If Right$((Me.txtUsagePeriod), 2) = "11" Then
strMMM = "Nov"
Else
If Right$((Me.txtUsagePeriod), 2) = "12" Then
strMMM = "Dec"
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
'Set the starting and ending sheet numbers for each filename in Excel
If ((cboFilename = "IP Check") And (Right$((Me.cboRunNo), 1) = 1)) Then
lngStartSheet = 6
lngEndSheet = 35
Else
If ((Me!cboFilename = "IP Check") And (Right$((Me.cboRunNo), 1) <> 1)) Then
lngStartSheet = 2
lngEndSheet = 35
Else
If Me.cboFilename = "AA Check" Then
lngStartSheet = 2
lngEndSheet = 5
Else
If Me.cboFilename = "MS Check" Then
lngStartSheet = 2
lngEndSheet = 6
Else
If Me.cboFilename = "PD Check" Then
lngStartSheet = 2
lngEndSheet = 2
Else
If Me.cboFilename = "CT Check" Then
lngStartSheet = 2
lngEndSheet = 2
Else
If Me.cboFilename = "PCCheck" Then
lngStartSheet = 2
lngEndSheet = 31
Else
If Me.cboFilename = "PCDaily Check" Then
lngStartSheet = 2
lngEndSheet = 33
Else
If Me.cboFilename = "CA Check" Then
lngStartSheet = 3
lngEndSheet = 5
End If
End If
End If
End If
End If
End If
End If
End If
End If
'Set the run number for the entire path
If Right$((Me.cboRunNo), 1) <> 1 Then
strRun = "R" & Right$((Me.cboRunNo), 1) & "_"
Else
strRun = ""
End If
'Set the file extension
If (Me.cboFilename) = "IP Check" Then
strExtension = ".xlsm"
Else
strExtension = ".xlsx"
End If
'Set the full filename
strFilename = (Me.cboFilename) & "_" & strRun & (Me.txtUsagePeriod) &
strExtension
'Set the entire path
strPath = strMainPath & strFilePath & strAddPath & strMMM & " " &
Left$((Me.txtUsagePeriod), 4) _
& "\" & strFilename
'Set the table name that all the data is to be appended to
strTable = "tblAllRuns"
'Set a password for the Excel files
'(e.g. if none: strPassword = vbNullString)
'(e.g. if password: strPassword = "passwordtext")
strPassword = vbNullString
'Open Excel in read-only mode
blnReadOnly = True
'Open the Excel file and read the worksheet names into a collection in Access
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPath, , blnReadOnly, ,
strPassword)
intNoOfSheets = objWorkbook.Worksheets.Count
For lngCount = lngStartSheet To lngEndSheet
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount
'Close Excel 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
End If
'Import the data from each worksheet into the table
For Each objWorksheet In colWorksheets
Set objRange = objWorksheet.UsedRange
strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tblAllRuns",
strFilename, True, strWorksheetName
Next
'Delete the collection from Access
Set colWorksheets = Nothing
'Create Message box popup to show import is complete
MsgBox "Your files have been imported", vbOKOnly
End Sub
db is to hold data for quarterly reporting. I am trying to do the following:
Import specific spreadsheets from Excel 2007 workbooks based on information
entered on the main form and append the data to a single table in the
database. Each workbook has a different number of worksheets, each worksheet
has a different range of data, and each workbook has beginning and ending
worksheets that I do not need. There are a lot of things I have to define in
order for it to pull the correct file and this is working, but when it gets
to the section where it is to import data from the sheets to the table in
Access, it bugs out with msg "Run-time error '424': Object required". Can you
help? Here is the code and thanks in advance (KCCC):
Private Sub cmdImport_Click()
Dim blnHasFieldNames As Boolean, blnExcel As Boolean, blnReadOnly As Boolean
Dim lngCount As Long, lngStartSheet As Long, lngEndSheet As Long
Dim objExcel As Object, objWorkbook As Object, objRange As Object,
objWorksheet As Object
Dim colWorksheets As Collection
Dim intNoOfSheets As Integer
Dim strTable As String, strPassword As String, strWorksheetName As String
Dim strPath As String, strMainPath As String, strFilePath As String,
strAddPath As String, strMMM As String
Dim strRun As String, strExtension As String, strFilename As String
'Establish an Excel aapplication 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
'True if the first row in Excel worksheet has fieldnames
blnHasFieldNames = True
'Set the main part of the path (root)
strMainPath = "\\Share\Company\Fin\01\Service\"
'Set the middle part of the path
If Left$((Me.cboFilename), 2) = "CA" Then
strFilePath = "IV\CA Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "IP" Then
strFilePath = "IV\IP Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "PD" Then
strFilePath = "IV\PD Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "AA" Then
strFilePath = "IV\IP Verif\AA and MS\"
Else
If Left$((Me.cboFilename), 2) = "MS" Then
strFilePath = "IV\IP Verif\AA and MS\"
Else
If Left$((Me.cboFilename), 2) = "CT" Then
strFilePath = "PCV\CT Verif\VCC\"
Else
If Left$((Me.cboFilename), 2) = "PR" Then
strFilePath = "PCV\PCVC\"
End If
End If
End If
End If
End If
End If
End If
'Set the specific date folders of the path
strAddPath = Left((Me.txtUsagePeriod), 4) & "\" &
Right$((Me.txtUsagePeriod), 2) & "_"
'Set the 3 char month name
If Right$((Me.txtUsagePeriod), 2) = "01" Then
strMMM = "Jan"
Else
If Right$((Me.txtUsagePeriod), 2) = "02" Then
strMMM = "Feb"
Else
If Right$((Me.txtUsagePeriod), 2) = "03" Then
strMMM = "Mar"
Else
If Right$((Me.txtUsagePeriod), 2) = "04" Then
strMMM = "Apr"
Else
If Right$((Me.txtUsagePeriod), 2) = "05" Then
strMMM = "May"
Else
If Right$((Me.txtUsagePeriod), 2) = "06" Then
strMMM = "Jun"
Else
If Right$((Me.txtUsagePeriod), 2) = "07" Then
strMMM = "Jul"
Else
If Right$((Me.txtUsagePeriod), 2) = "08" Then
strMMM = "Aug"
Else
If Right$((Me.txtUsagePeriod), 2) = "09" Then
strMMM = "Sep"
Else
If Right$((Me.txtUsagePeriod), 2) = "10" Then
strMMM = "Oct"
Else
If Right$((Me.txtUsagePeriod), 2) = "11" Then
strMMM = "Nov"
Else
If Right$((Me.txtUsagePeriod), 2) = "12" Then
strMMM = "Dec"
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
'Set the starting and ending sheet numbers for each filename in Excel
If ((cboFilename = "IP Check") And (Right$((Me.cboRunNo), 1) = 1)) Then
lngStartSheet = 6
lngEndSheet = 35
Else
If ((Me!cboFilename = "IP Check") And (Right$((Me.cboRunNo), 1) <> 1)) Then
lngStartSheet = 2
lngEndSheet = 35
Else
If Me.cboFilename = "AA Check" Then
lngStartSheet = 2
lngEndSheet = 5
Else
If Me.cboFilename = "MS Check" Then
lngStartSheet = 2
lngEndSheet = 6
Else
If Me.cboFilename = "PD Check" Then
lngStartSheet = 2
lngEndSheet = 2
Else
If Me.cboFilename = "CT Check" Then
lngStartSheet = 2
lngEndSheet = 2
Else
If Me.cboFilename = "PCCheck" Then
lngStartSheet = 2
lngEndSheet = 31
Else
If Me.cboFilename = "PCDaily Check" Then
lngStartSheet = 2
lngEndSheet = 33
Else
If Me.cboFilename = "CA Check" Then
lngStartSheet = 3
lngEndSheet = 5
End If
End If
End If
End If
End If
End If
End If
End If
End If
'Set the run number for the entire path
If Right$((Me.cboRunNo), 1) <> 1 Then
strRun = "R" & Right$((Me.cboRunNo), 1) & "_"
Else
strRun = ""
End If
'Set the file extension
If (Me.cboFilename) = "IP Check" Then
strExtension = ".xlsm"
Else
strExtension = ".xlsx"
End If
'Set the full filename
strFilename = (Me.cboFilename) & "_" & strRun & (Me.txtUsagePeriod) &
strExtension
'Set the entire path
strPath = strMainPath & strFilePath & strAddPath & strMMM & " " &
Left$((Me.txtUsagePeriod), 4) _
& "\" & strFilename
'Set the table name that all the data is to be appended to
strTable = "tblAllRuns"
'Set a password for the Excel files
'(e.g. if none: strPassword = vbNullString)
'(e.g. if password: strPassword = "passwordtext")
strPassword = vbNullString
'Open Excel in read-only mode
blnReadOnly = True
'Open the Excel file and read the worksheet names into a collection in Access
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPath, , blnReadOnly, ,
strPassword)
intNoOfSheets = objWorkbook.Worksheets.Count
For lngCount = lngStartSheet To lngEndSheet
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount
'Close Excel 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
End If
'Import the data from each worksheet into the table
For Each objWorksheet In colWorksheets
Set objRange = objWorksheet.UsedRange
strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tblAllRuns",
strFilename, True, strWorksheetName
Next
'Delete the collection from Access
Set colWorksheets = Nothing
'Create Message box popup to show import is complete
MsgBox "Your files have been imported", vbOKOnly
End Sub