0
\$\begingroup\$

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("$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

    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
\$\endgroup\$
0

2 Answers 2

0
\$\begingroup\$

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

\$\endgroup\$
1
  • 1
    \$\begingroup\$ 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. \$\endgroup\$
    – BlueFlame
    Sep 23 at 20:24
0
\$\begingroup\$

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;
\$\endgroup\$
3
  • \$\begingroup\$ 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. \$\endgroup\$
    – BlueFlame
    Sep 23 at 17:00
  • \$\begingroup\$ "the issue has something to do with Access" because "OLE automation is slow". \$\endgroup\$
    – FreeMan
    Sep 23 at 17:03
  • \$\begingroup\$ 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. \$\endgroup\$
    – Greedo
    Sep 24 at 16:51

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.