Code:
Option Compare Database
Option Explicit
Sub Import()
Dim ReturnArray As Variant, vMonths As Variant
Dim sSQL As String, Filepath As String, FileName As String, sYear As String, sYear2 As String, YearSelect As String
Dim sClass As String, sWeight As String, sSource As String
Dim ReportingDate As Date
Dim i As Long, k As Long, l As Long, m As Long
Dim j As Integer
Dim icount As Long, Loops As Long, CheckM As Long
Dim db As Database
Dim appExcel As Excel.Application
Dim wb As Excel.Workbook
Dim n As Double
Set appExcel = CreateObject("Excel.Application")
Set db = CurrentDb
sYear = IIf(Month(Date) < 4, Year(Date) + 1 & " " & Right(Year(Date) + 2, 2), Year(Date) & " " & Right(Year(Date) + 1, 2))
sYear2 = IIf(Month(Date) < 4, Year(Date) + 1 & " " & Year(Date) + 2, Year(Date) & " " & Year(Date) + 1)
Filepath = "IMPORT PATH" & sYear & "\Outgoing " & sYear2 & "\"
vMonths = Array("April", "May", "June", "July", "August", "September", "October", "November", "December", "January", "February", "March")
For i = 0 To UBound(vMonths)
sYear = IIf(Month(Date) < 4, Year(Date) + 1, Year(Date))
FileName = vMonths(i) & " " & sYear & ".xls"
If i > Month(Date) - 4 Then Exit For
Set wb = appExcel.Workbooks.Open(Filepath & FileName)
appExcel.Visible = True
For j = 1 To 31
With wb.Worksheets(Addth(j))
ReturnArray = .Range(.Cells(1, 1), .Cells(70, 36)).Value
End With
For k = 5 To UBound(ReturnArray, 1)
For l = 4 To UBound(ReturnArray, 2)
On Error Resume Next
ReportingDate = CDate(j & "/" & vMonths(i) & "/" & sYear)
If Err.Number = 13 Then GoTo DateError
On Error GoTo 0
sSource = IIf(ReturnArray(k, 3) = "", sSource, ReturnArray(k, 3))
If sSource = "0" Then GoTo Nextk
sClass = IIf(ReturnArray(3, l) = "", sClass, ReturnArray(3, l))
sWeight = IIf(ReturnArray(4, l) = "", sWeight, ReturnArray(4, l))
If InStr(1, sWeight, "total value", TextCompare) > 0 Or InStr(1, sWeight, "Total Value", TextCompare) > 0 Or InStr(1, sWeight, "Year End Billing - Revenues", TextCompare) > 0 Or InStr(1, sWeight, "Total Qty", TextCompare) > 0 Then GoTo Nextl
icount = ReturnArray(k, l)
If Not Trim(sSource) = "Totals" And Not InStr(1, ReturnArray(3, l), "Value", vbTextCompare) > 0 = "" And Not InStr(1, ReturnArray(4, l), "Total", vbTextCompare) > 0 Then
CheckM = m
On Error Resume Next
If Err.Number = 3734 Then GoTo ErrorHandler
If dCount("*", "OutgoingPost", "ReportingDate = " & CDbl(ReportingDate) & " AND Source = '" & Replace(sSource, "'", "") & "' AND Class = '" & sClass & "' AND Weight = '" & sWeight & "'") = 0 Then
sSQL = "INSERT INTO OutgoingPost (ReportingDate, Source, Class, Weight, Count) VALUES (" & CDbl(ReportingDate) & ", '" & Replace(sSource, "'", "") & "', '" & sClass & "', '" & sWeight & "', " & icount & ");"
db.Execute (sSQL)
m = m + 1
ElseIf dCount("*", "OutgoingPost", "ReportingDate = " & CDbl(ReportingDate) & " AND Source = '" & Replace(sSource, "'", "") & "' AND Class = '" & sClass & "' AND Weight = '" & sWeight & "' AND Count = " & icount) = 0 Then
sSQL = "UPDATE OutgoingPost SET [Count] = " & icount & ";"
db.Execute (sSQL)
m = m + 1
End If
On Error GoTo 0
sSQL = Empty
End If
If m >= 150 Or Loops >= 1500 Or (m > 0 And Loops > 0 And m + Loops >= 1500) Then
DoEvents
If m >= 150 Then Debug.Print "EDITS: " & Time() & ", " & ReportingDate & ", " & sSource & ", " & sClass & ", " & sWeight
If Loops >= 1500 Then Debug.Print "LOOPS: " & Time() & ", " & ReportingDate & ", " & sSource & ", " & sClass & ", " & sWeight
If m > 0 And Loops > 0 And m + Loops >= 1500 Then Debug.Print "COMBO: " & Time() & ", " & ReportingDate & ", " & sSource & ", " & sClass & ", " & sWeight
m = 0
Loops = 0
End If
If CheckM = m Then Loops = Loops + 1
Nextl:
Next l
Nextk:
Next k
DateError:
On Error GoTo 0
Next j
wb.Close (False)
Set wb = Nothing
Next i
Set appExcel = Nothing
Exit Sub
ErrorHandler:
Resume
End Sub