VBA code which exports data from Access to Excel and then loops through the Excel file

Question

I have a couple of VBA loops that work in the blink of eye when I execute them through Excel, but doing this as part of an Access VBA application takes like 15 minutes. The loops run through each row and check to see if multiple conditions are met, and if they are they change the value of one cell in the row in question.

This is the database code pertaining to the Excel portion:

With MyExcel
 .Workbooks.Open ReportName
 Set WB = GetObject(ReportName)
 WB.DisplayAlerts = False
 WB.Sheets(2).Select
 WB.Sheets(3).Select
 WB.Sheets(3).Columns("E:F").Delete
 WB.Sheets(3).Columns("G:G").Delete
 WB.Sheets(3).Columns("AF:AF").Delete
 WB.Sheets(3).Columns("A:AE").NumberFormat = "@"
 LastRow = WB.Sheets(3).Range("A2").End(xlDown).Row
 For i = 2 To LastRow
 If WB.Sheets(3).Cells(i, 6).Value = 2 Then
 WB.Sheets(3).Rows(i).Copy Destination:=WB.Sheets(3).Rows(WB.Sheets(3).Range("A2").End(xlDown).Row + 1)
 ElseIf WB.Sheets(3).Cells(i, 6).Value = 4 Then
 WB.Sheets(3).Rows(i).Copy Destination:=WB.Sheets(3).Rows(WB.Sheets(3).Range("A2").End(xlDown).Row + 1)
 WB.Sheets(3).Rows(i).Copy Destination:=WB.Sheets(3).Rows(WB.Sheets(3).Range("A2").End(xlDown).Row + 1)
 WB.Sheets(3).Rows(i).Copy Destination:=WB.Sheets(3).Rows(WB.Sheets(3).Range("A2").End(xlDown).Row + 1)
 End If
 Next i
 With WB.Sheets(3).Range("A1:AE" & LastRow)
 .WrapText = False
 .Orientation = 0
 .AddIndent = False
 .IndentLevel = 0
 .ShrinkToFit = False
 .ReadingOrder = xlContext
 .MergeCells = False
 End With
 WB.Sheets(3).Range("A1").AutoFilter
 LastRow = WB.Sheets(3).Range("A2").End(xlDown).Row
 WB.Sheets(3).ListObjects.Add(xlSrcRange, WB.Sheets(3).Range("$A1ドル:$AE$" & LastRow), , xlYes).Name = "tblAccess"
 WB.Sheets(3).ListObjects("tblAccess").TableStyle = "TableStyleLight8"
 WB.Sheets(3).ListObjects("tblAccess").Sort.SortFields.Clear
 WB.Sheets(3).ListObjects("tblAccess").Sort.SortFields. _
 Add Key:=WB.Sheets(3).Range("tblAccess[NDC NUMBER]"), SortOn:=xlSortOnValues, Order:= _
 xlAscending, DataOption:=xlSortNormal
 WB.Sheets(3).ListObjects("tblAccess").Sort.SortFields. _
 Add Key:=WB.Sheets(3).Range("tblAccess[GROUP_ID]"), SortOn:=xlSortOnValues, Order:= _
 xlAscending, DataOption:=xlSortNormal
 With WB.Sheets(3).ListObjects("tblAccess").Sort
 .Header = xlYes
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 End With
 For i = 2 To LastRow
 If WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "New QL" Then
 WB.Sheets(3).Cells(i, 7) = "QLL OUT OF RANGE"
 ElseIf WB.Sheets(3).Cells(i, 2) <> WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "New QL" Then
 WB.Sheets(3).Cells(i, 7) = "QLL IN RANGE"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "New PA" Then
 WB.Sheets(3).Cells(i, 7) = "New PA-1"
 ElseIf WB.Sheets(3).Cells(i, 2) <> WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "New PA" Then
 WB.Sheets(3).Cells(i, 7) = "New PA-2"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "Uptiered/Modify QL" Then
 WB.Sheets(3).Cells(i, 7) = "Uptiered/Modify QL-1"
 ElseIf WB.Sheets(3).Cells(i, 2) <> WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "Uptiered/Modify QL" Then
 WB.Sheets(3).Cells(i, 7) = "Uptiered/Modify QL-2"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "Modify QL" Then
 WB.Sheets(3).Cells(i, 7) = "Modify QL-1"
 ElseIf WB.Sheets(3).Cells(i, 2) <> WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 2 And WB.Sheets(3).Cells(i, 7) = "Modify QL" Then
 WB.Sheets(3).Cells(i, 7) = "Modify QL-2"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "Modify QL" _
 And WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 2, 2) And WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 3, 2) Then
 WB.Sheets(3).Cells(i, 7) = "Modify QL-1"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "Modify QL" _
 And WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 2, 2) Then
 WB.Sheets(3).Cells(i, 7) = "Modify QL-2"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "Modify QL" Then
 WB.Sheets(3).Cells(i, 7) = "Modify QL-3"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i - 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "Modify QL" Then
 WB.Sheets(3).Cells(i, 7) = "Modify QL-4"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "New QL" _
 And WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 2, 2) And WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 3, 2) Then
 WB.Sheets(3).Cells(i, 7) = "QLL OUT OF RANGE PA ADDED"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "New QL" _
 And WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 2, 2) Then
 WB.Sheets(3).Cells(i, 7) = "QLL OUT OF RANGE NO PA"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i + 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "New QL" Then
 WB.Sheets(3).Cells(i, 7) = "QLL IN RANGE PA ADDED"
 ElseIf WB.Sheets(3).Cells(i, 2) = WB.Sheets(3).Cells(i - 1, 2) And WB.Sheets(3).Cells(i, 6) = 4 And WB.Sheets(3).Cells(i, 7) = "New QL" Then
 WB.Sheets(3).Cells(i, 7) = "QLL IN RANGE NO PA"
 Else
 WB.Sheets(3).Cells(i, 7) = WB.Sheets(3).Cells(i, 7)
 End If
 Next i
 WB.Sheets("POS_Claims").Activate
 WB.Sheets("POS_Claims").ListObjects("tblMain").Resize WB.Sheets("POS_Claims").Range("$A1ドル:$MI$" & LastRow)
 WB.Sheets("POS_Claims").Range("C2") = "=tblAccess[@[BIN]]"
 WB.Sheets("POS_Claims").Range("D2") = "=tblAccess[@[PCN]]"
 WB.Sheets("POS_Claims").Range("Y2") = "=tblAccess[@[GROUP_ID]]"
 WB.Sheets("POS_Claims").Range("AT2") = "=tblAccess[@[NDC NUMBER]]"
 WB.Sheets("POS_Claims").Range("FT2") = "=tblAccess[@[Testing Scenarios]]"
 WB.Sheets("POS_Claims").Range("HI2") = "=tblAccess[@[PAUTH_IND]]"
 WB.Sheets("POS_Claims").Range("HJ2") = "=tblAccess[@[PAUTH_Start_Date]]"
 WB.Sheets("POS_Claims").Range("HK2") = "=tblAccess[@[PAUTH_End_Date]]"
 WB.Sheets("POS_Claims").Range("HN2") = "=tblAccess[@[PAUTH_SPEC_OV]]"
 WB.Sheets("POS_Claims").Range("HO2") = "=tblAccess[@[PAUTH_SPEC_COPAY_OV]]"
 WB.Sheets("POS_Claims").Range("HS2") = "=tblAccess[@[PAUTH_MEDB_OV]]"
 WB.Sheets("POS_Claims").Range("HU2") = "=tblAccess[@[PAUTH_CLAIM_SUB]]"
 WB.Sheets("POS_Claims").Range("HV2") = "=tblAccess[@[PAUTH_CAP_OV]]"
 WB.Sheets("POS_Claims").Range("HY2") = "=tblAccess[@[PAUTH_AUTH_TYPE]]"
 WB.Sheets("POS_Claims").Range("IC2") = "=tblAccess[@[PAUTH_DAW]]"
 WB.Sheets("POS_Claims").Range("ID2") = "=tblAccess[@[PAUTH_MAX_DOSE]]"
 WB.Sheets("POS_Claims").Range("IF2") = "=tblAccess[@[PAUTH_DENY_COV]]"
 WB.Sheets("POS_Claims").Range("IG2") = "=tblAccess[@[PAUTH_PRICE_POINT_IND]]"
 WB.Sheets("POS_Claims").Range("II2") = "=tblAccess[@[PAUTH_Brand_COPAY_OV]]"
 WB.Sheets("POS_Claims").Range("IJ2") = "=tblAccess[@[PAUTH_RTS]]"
 WB.Sheets("POS_Claims").Range("JF2") = "=tblAccess[@[MBA_Indicator]]"
 WB.Sheets("POS_Claims").Range("A1:MI" & LastRow).Copy
 WB.Sheets("POS_Claims").Range("A1:MI" & LastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
 :=False, Transpose:=False
 WB.Application.CutCopyMode = False
 WB.Sheets("POS_Claims").ListObjects(1).Unlist
 WB.Sheets("POS_Claims").Range("A1:MI" & LastRow).Replace What:="0", Replacement:="", LookAt:=xlPart, _
 SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
 ReplaceFormat:=False
 WB.Sheets("POS_Claims").Range("A2").Select
 WB.Close SaveChanges:=True
End With

Answer 1

Two options:

1. Move your Excel code back to Excel.
2. Make this code run on open.
3. Open the workbook from Access and the code will run.
   1. Update the code to save & close the workbook when it's done.

Alternatively:

1. Move your Excel code back to Excel in a "standard" module.
2. Call the Excel method from Access code:

 Set Rpt = XLobj.Workbooks.Open(ExcelFileName)
 Rpt.Application.Run ExcelMacroName 'you can provide parameters to the function here if needed/desired
 Rpt.Close False

This will open Excel, run the code within Excel, then close the file

• BlueFlame: Thank you so much this worked perfect! I put the code inside of the Excel template that I link to and just called it from there and it runs in less than a minute.

Answer 2

OLE automation is slow; however, you can speed up things by disabling screen updating and calculations temporarily

MyExcel.ScreenUpdating = False
MyExcel.Calculation = xlCalculationManual
'Do your work here ...
MyExcel.ScreenUpdating = True;
MyExcel.Calculation = xlCalculationAutomatic;

• BlueFlame: Yeah I tried this and it doesn't help. It's so weird because I only have about 3,000 rows of data and the actual loops when ran from just the Excel are instant, so the issue has something to do with Access.
• FreeMan: "the issue has something to do with Access" because "OLE automation is slow".
• Greedo: Why is it slow? I'm guessing because Excel and Access run in different threads and there is a lot of synchronisation overhead? Whereas Excel VBA runs from within Excel runs in the main application ui thread and so there is no waiting to do.