1
\$\begingroup\$

Could you please help me optimize the macro, Its taking more than 50 minutes but still no success.

The For loop is looping untill 1.0 million + rows. Screen is flickering. I have tried Application.ScreenUpdating = True but it still flickers and for loop is taking very long time.

I am downloading reports from sharepoint and checking for past 7 days file.

File Names:

Fsplit2 = "Interim Inventory Tracker - All States " & Format(Now - i, "mmddyy") & " v1.xlsx"

F4 = "Inventory Export " & Format(Now - i, "yyyy-mm-dd") & " AM.xlsm"

From f4 i am updating values into Fsplit2 based on the Group name and conditions mentioned below in code.

Sub DownloadPastInterimTracker()
    Dim myURL As String
    Dim f1 As String
    Dim f2 As String
    Dim WinHttpReq As Object


    Fsplit1 = "https://share.antheminc.com/projects/Facets-Mig/Plan/Interim%20Inventory%20Tracker/"

     'File handles upto 7 days
   For i = 1 To 7
            Fsplit2 = "Interim Inventory Tracker - All States " & Format(Now - i, "mmddyy") & " v1.xlsx"
             myURL = Fsplit1 & Fsplit2
           Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
           WinHttpReq.Open "GET", myURL, False
          WinHttpReq.Send

          If WinHttpReq.Status = 200 Then
             Set oStream = CreateObject("ADODB.Stream")
             oStream.Open
            oStream.Type = 1
            oStream.Write WinHttpReq.ResponseBody
            oStream.SaveToFile ("C:\Users\AG47552\Desktop\Interim Tracker\Yesterday's Tracker File\" & Fsplit2 & " ")
            oStream.Close
            i = 7

            MsgBox " File Downloaded Successfully  "
        End If   
Next i

Call OpenInterimTracker(Fsplit2)
Call CentralLookup(Fsplit2)
Call NortheastLookup(Fsplit2)
Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Save
Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Close
Call DownloadTableauTracker(Fsplit2)

End Sub

Sub OpenInterimTracker(ByVal Fsplit2 As String)

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True

    Dim sPath As String, sFile As String
    Dim wb As Workbook
    Application.ScreenUpdating = True
    sPath = "C:\Users\AG47552\Desktop\Interim Tracker\Yesterday's Tracker File\"
    sFile = sPath & Fsplit2
    Set wb = Workbooks.Open(sFile)

End Sub

Sub CentralLookup(ByVal Fsplit2 As String)

Dim rnge as Range
Dim cl As range


Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
Worksheets("Central").Activate
lastrow = range("A" & Rows.Count).End(xlUp).Row

   For i = 2 To lastrow
      If Application.WorksheetFunction.IsNA(range("g" & i).Value) Then
         range("g" & i).Value = "Change"
      End If

     If range("g" & i).Value = "Change" Then
        srchval = Trim(range("d" & i).Value)
        chgval = Trim(range("e" & i).Value)

            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").Activate
            On Error Resume Next
             get_row_number = Workbooks(Fsplit2). _
                              Sheets("Main Data input").range("D:D").Find( _
              What:=srchval, _
              LookIn:=xlValues, _
              LookAt:=xlPart, _
              SearchOrder:=xlByColumns, _
              SearchDirection:=xlNext, _
              MatchCase:=True _
              ).Row

        If get_row_number = "" Then
            'do nothing
        Else
            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").range("H" & get_row_number).Value = chgval
            chgval = ""
            chgval.Interior.Color = vbGreen
        End If
        Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
        Worksheets("Central").Activate
     End If
    Next i
End Sub

Sub NortheastLookup(ByVal Fsplit2 As String)

Dim rnge as Range
Dim cl As range


Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
Worksheets("Northeast").Activate
lastrow = range("A" & Rows.Count).End(xlUp).Row

   For i = 2 To lastrow
      If Application.WorksheetFunction.IsNA(range("g" & i).Value) Then
         range("g" & i).Value = "Change"
      End If

     If range("g" & i).Value = "Change" Then
        srchval = Trim(range("d" & i).Value)
        chgval = Trim(range("e" & i).Value)

            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").Activate
            On Error Resume Next
             get_row_number = Workbooks(Fsplit2). _
                              Sheets("Main Data input").range("D:D").Find( _
              What:=srchval, _
              LookIn:=xlValues, _
              LookAt:=xlPart, _
              SearchOrder:=xlByColumns, _
              SearchDirection:=xlNext, _
              MatchCase:=True _
              ).Row

        If get_row_number = "" Then
            'do nothing
        Else
            Workbooks(Fsplit2).Activate
            Sheets("Main Data input").range("H" & get_row_number).Value = chgval
            chgval = ""
            chgval.Interior.Color = vbGreen
        End If
        Workbooks("Trackers " & Format(Now, "MMDDYY") & " PM.xlsx").Activate
        Worksheets("Central").Activate
       End If
    Next i
End Sub

Sub DownloadTableauTracker(ByVal Fsplit2 As String)

    Dim myURL As String
    Dim f1 As String
    Dim f2 As String
    Dim f3 As String
    Dim f4 As String

    Dim WinHttpReq As Object

    f1 = "https://share.antheminc.com/sites/EET-Migrations/Migrations%20Tracker/Migrations_Tracker%20_Tableau/"
    f2 = "" & Year(Date) & "/"
    f3 = "" & Format(Now, "mm mmm yyyy") & "/"

    For i = 0 To 2

    f4 = "Inventory Export " & Format(Now - i, "yyyy-mm-dd") & " AM.xlsm"

           myURL = f1 & f2 & f3 & f4
           Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
           WinHttpReq.Open "GET", myURL, False
          WinHttpReq.Send

          If WinHttpReq.Status = 200 Then
             Set oStream = CreateObject("ADODB.Stream")
             oStream.Open
            oStream.Type = 1
            oStream.Write WinHttpReq.ResponseBody
            oStream.SaveToFile ("C:\Users\AG47552\Desktop\Interim Tracker\Tableau Tracker\" & f4 & " ")
            oStream.Close
            i = 5

            MsgBox " Tableau Inventory file downloaded "
        End If     
Next i
Call TableauInventoryOpen(f4)
Call FetchTableauStatus(Fsplit2, f4)
End Sub

Sub TableauInventoryOpen(ByVal f4 As String)

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True

    Dim sPath As String, sFile As String
    Dim wb As Workbook
    Application.ScreenUpdating = True
    sPath = "C:\Users\AG47552\Desktop\Interim Tracker\Tableau Tracker\"
    sFile = sPath & f4
    Set wb = Workbooks.Open(sFile)

End Sub

Sub FetchTableauStatus(ByVal Fsplit2 As String, ByVal f4 As String)

Workbooks(Fsplit2).Activate
Worksheets("Main Data input").Activate
lastrow = range("b" & Rows.Count).End(xlUp).Row

   For i = 3 To lastrow

            srchval = Trim(range("d" & i).Value)
            'chgval = Trim(Range("e" & i).Value)

            Workbooks(f4).Activate
            Sheets("Inventory Export").Activate
            On Error Resume Next
             get_row_number = Workbooks(f4). _
                              Sheets("Inventory Export").range("G:G").Find( _
              What:=srchval, _
              LookIn:=xlValues, _
              LookAt:=xlPart, _
              SearchOrder:=xlByColumns, _
              SearchDirection:=xlNext, _
              MatchCase:=True _
              ).Row

             If get_row_number = "" Then
                'do nothing
             Else
          'Finalize Product and Admin Selections

               Workbooks(f4).Activate
               If Sheets("Inventory Export").range("z" & get_row_number).Value = "Complete" Then
                  Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
                  If Sheets("Main Data input").range("O" & i).Value = "Incomplete" Or _
                     Sheets("Main Data input").range("o" & i).Value = "Incomplete with Issues" Then
                     Sheets("Main Data input").range("o" & i).Value = "Complete"
                  End If
                End If
           'Implementation Case Status
                  copyval = ""
                  Workbooks(f4).Activate
                If Sheets("Inventory Export").range("o" & get_row_number).Value = "Implementation Completed" Or _
                   Sheets("Inventory Export").range("o" & get_row_number).Value = "NULL" Then
                    'do nothing
                Else
                    Workbooks(f4).Activate
                    copyval = Sheets("Inventory Export").range("o" & get_row_number).Value
                  Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
                  Sheets("Main Data input").range("j" & i).Value = copyval
               End If
           'E&B Audit Complete
               Workbooks(f4).Activate
               If Sheets("Inventory Export").range("r" & get_row_number).Value = "Complete" Then
                  Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
                  If Sheets("Main Data input").range("l" & i).Value = "Incomplete" Or _
                     Sheets("Main Data input").range("l" & i).Value = "Incomplete with Issues" Then
                     Sheets("Main Data input").range("l" & i).Value = "Complete"
                  End If
                End If
             End If
        Workbooks(Fsplit2).Activate
                  Worksheets("Main Data input").Activate
     Next i

Workbooks(f4).Close
Workbooks(Fsplit2).Saveas "C:\Users\AG47552\Desktop\Interim Tracker\Today's Tracker File\" & Fsplit2 & " "
End Sub
\$\endgroup\$
4
  • 1
    \$\begingroup\$ For best performance Application.ScreenUpdating should be set to false, set it to true when the update is done. \$\endgroup\$
    – pacmaninbw
    Commented Apr 24, 2020 at 0:06
  • \$\begingroup\$ Please explain what the macro does so that we understand the code. Depending on the size of the files being downloaded, this could take some time. Is it possible to use file compression before downloading the files? \$\endgroup\$
    – pacmaninbw
    Commented Apr 24, 2020 at 0:09
  • 1
    \$\begingroup\$ There are certainly things that can be improved in this script, but you should identify the problematic areas - is this the download proper or your processing routine. Without having a data sample at hand it is difficult to realistically assess the code and we cannot guess all that you are doing. If you add some debug.print statements here and there it should become obvious which parts of the code take disproportionately more time than others. But I am not surprised that looping over 1M rows takes time. Perhaps you could export to csv and inject to a DB or process the data differently. \$\endgroup\$
    – Kate
    Commented Apr 24, 2020 at 14:04
  • 1
    \$\begingroup\$ Another point is that your execution time may be driven by the slow response of the Sharepoint server and your network, having little to do with your code. The comment from @Anonymous is on point: we can help identify the bottleneck better with more information such as sample data. Also try operating on data already "downloaded" from your Sharepoint site and see how much time that takes in order to help factor where your problem(s) lie. \$\endgroup\$
    – PeterT
    Commented Apr 27, 2020 at 14:51

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.