Solved VBA code which exports data from Access to Excel and then loops through the Excel file (1 Viewer)

[BlueFllame]

Hey guys,

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.

EDIT: I found the answer in another thread:

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

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

'First loop that causes the problem:
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("$A$1:$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

'Second problematic loop:
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("$A$1:$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