>
Oh, you're making this WAY harder than it has to be. How about linking
to the Spreadsheet, and then querying for the data you want. then you
can turn that into an append query and you're done. No code required.
If only I could, the problem is I have about 10 workbooks with a number
of worksheets that can be added to or taken away from dynamically,
therefore the only way to get all the data in is to loop through all of
the worksheets in the workbook and pick up the ones with the relevant
name, I've inserted the code here:
Function Get_Historical_AOD_Hours()
On Error GoTo Err_Handler
Dim xlApp As Object ' Excel.Application
Dim xlBook As Object ' Excel.Workbook
Dim xlSheet As Object ' Excel.Worksheet
Dim strPath As String
Dim Workbook_Array As Variant
Dim intI As Variant
Dim rowcount As Variant
'Dim startcol As Variant
'Dim endcol As Variant
Dim sheetRange As String
'Dim range As Variant
'Dim stage As String
Dim week_end As Variant
Dim CSCI As Variant
Dim AOD As Variant
Dim Phase As Variant
Dim Current_DB As Database
Dim rst As Recordset
Dim rst_update As Recordset
Dim rst_csci As Recordset
'Dim rst_status As Recordset
Dim XLTARGET As Variant
Dim Today As Variant
Dim csci_flag As Boolean
'MsgBox "i'd like to start"
Set Current_DB = DBEngine.Workspaces(0).Databases(0)
Set rst = Current_DB.OpenRecordset("Temp_Historical_Hours")
'MsgBox "oh my God"
Set rst_update = Current_DB.OpenRecordset("AOD_Historical_Hours")
'MsgBox "and even"
Set rst_csci = Current_DB.OpenRecordset("CSCI")
'MsgBox "and then"
'startcol = "B"
'endcol = "R"
XLTARGET = "Temp_Historical_Hours"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from Temp_Historical_Hours" 'Clear table
DoCmd.RunSQL "delete * from AOD_Historical_Hours" 'Clear table
MsgBox "running"
Set xlApp = CreateObject("Excel.Application")
'Path of the file being imported
Workbook_Array = Array("D:\N15_Charts\MSRS_&_RAP CTR iFACTS.xls",
"D:\N15_Charts\RDP & CMS CTR iFACTS.xls", "D:\N15_Charts\SEC CTR
iFACTS.xls", "D:\N15_Charts\WDM & SCC CTR iFACTS.xls",
"D:\N15_Charts\CGW_&_SIS CTR iFACTS.xls", "D:\N15_Charts\CxSS CTR
iFACTS.xls", "D:\N15_Charts\FDP CTR iFACTS.xls",
"D:\N15_Charts\ADS_&_TOOLS CTR iFACTS.xls", "D:\N15_Charts\CMTOOLS CTR
iFACTS.xls")
For Each intI In Workbook_Array
strPath = intI
'Establish workbook string
Set xlBook = xlApp.workbooks.Open(strPath, False, True)
'Loop through all the Sheets in the workbook
For Each xlSheet In xlBook.Worksheets
On Error Resume Next
sheetRange = xlSheet.Name
'if the worksheet's name contains EV then import the data
If sheetRange Like "*EV*" Then
'Transfer the data from the worksheet
DoCmd.TransferSpreadsheet acImport, _
acSpreadsheetTypeExcel5, _
XLTARGET, _
strPath, _
False, _
xlSheet.Name & "!A25:J80"
Set rst = Current_DB.OpenRecordset("Temp_Historical_Hours")
'Get the overarching data into local variables
CSCI = xlSheet.Name
csci_flag = False
rst_csci.MoveFirst
Do While Not rst_csci.EOF And Not csci_flag
If CSCI Like "*" & rst_csci!CSCI.Value & "*" Then
csci_flag = True
CSCI = rst_csci!CSCI.Value
End If
rst_csci.MoveNext
Loop
AOD = rst!F1.Value
Phase = rst!F2.Value
'Get today's date
Today = CDate(FormatDateTime(Now, vbShortDate))
'move to the first record with a date in it, know this from
the spreadsheet
rst.MoveNext
rst.MoveNext
'convert to date format
week_end = CDate(FormatDateTime(rst!F1.Value, vbShortDate))
Do While Not IsEmpty(CDate(FormatDateTime(rst!F1.Value,
vbShortDate)))
If IsEmpty(CDate(FormatDateTime(rst!F1.Value, vbShortDate)))
Then
MsgBox "this is not actually possible"
End If
'On Error Resume Next
'MsgBox "I'm in"
rst_update.AddNew
rst_update![AOD] = AOD
rst_update![Week Ending] =
CDate(FormatDateTime(rst!F1.Value, vbShortDate))
If IsNull(rst_update![Week Ending]) Then
MsgBox "this is driving me round the bend"
End If
'MsgBox rst_update![Week Ending]
rst_update![CSCI] = CSCI
'MsgBox rst_update![CSCI]
rst_update![Phase] = Phase
'MsgBox rst_update![Phase]
rst_update![Hours Type] = "Implementation"
'MsgBox rst_update![Hours Type]
rst_update![Hours Total] = rst!F2.Value
'MsgBox rst_update![Hours Total]
rst_update![Phase % Complete] = rst!F10.Value
'MsgBox rst_update![Phase % Complete]
rst_update.Update
'MsgBox "and I should have done summat"
rst.MoveNext
'week_end = CDate(FormatDateTime(rst!F1.Value,
vbShortDate))
Loop
'end of status addition
'Commit changes to the recordset
'rst_update.Update
DoCmd.RunSQL "delete * from Temp_Historical_Hours" 'Clear
table
End If
'loop to next worksheet in workbook
Next
'MsgBox "Complete " & strPath
'loop to next workbook in array
Next
xlBook.Application.Quit
'Delete data that does not apply
DoCmd.OpenQuery "Delete_blanks"
'Delete last weeks data from tables AOD, CSCI_AOD, CSCI_AOD_Phase,
CSCI_AOD_HLD (DD, Code, CBT, UCT)
DoCmd.RunSQL "delete * from CSCI_AOD_HLD"
DoCmd.RunSQL "delete * from CSCI_AOD_DD"
DoCmd.RunSQL "delete * from CSCI_AOD_Code"
DoCmd.RunSQL "delete * from CSCI_AOD_UCT"
DoCmd.RunSQL "delete * from CSCI_AOD_CBT"
DoCmd.RunSQL "delete * from CSCI_AOD_Phase"
DoCmd.RunSQL "delete * from CSCI_AOD"
DoCmd.RunSQL "delete * from AOD"
'Run the append query to add this week's data in
DoCmd.OpenQuery "Append_AOD1"
DoCmd.OpenQuery "Append_CSCI_AOD"
'DoCmd.OpenQuery "Append_AOD_Phase"
'DoCmd.OpenQuery "Append_HLD"
'DoCmd.OpenQuery "Append_DD"
'DoCmd.OpenQuery "Append_Code"
'DoCmd.OpenQuery "Append_UCT"
'DoCmd.OpenQuery "Append_CBT"
'Error Handler used to catch error when the fields are blank
Exit Function
Exit_Handler:
On Error Resume Next
Err_Handler:
On Error Resume Next
End Function
