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
Application.ScreenUpdating
should be set to false, set it to true when the update is done. \$\endgroup\$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\$