I'd appreciate any help people can offer to make this process more efficient and less goofy. I've created a process to loop through a folder of approximately 100 files, add a new sheet with a base template to each one and add in data that is pulled from several saved reports via XLookup. It works! But, it's now taking about half an hour to run and is definitely the duct tape version rather than something efficient. It was taking less than 10 minutes, but now it's taking significantly longer. I removed the edits I had added but that didn't fix the time issue.
The macro file itself has a sheet that contains the file names for the various reports and is where I'm stashing a summary of the data for audit purposes. That same file also has a sheet with a template to be added to each one of the files in the specified folder, and a list of names/aka's since each report refers to the various parties for the files in a slightly different way. I am absolutely a VBA beginner, so any explanations and ideas are greatly appreciated! I've tried to limit the slowdown items that I know about, but I'm definitely missing something that is bogging this down. I've checked other questions and sources, but I'm not finding quite what I'm looking for. I'm using VBA from Office 365.
General process:
- Loop through folder of files to be updated.
- For each one, add a sheet with a template, and fill out that template with monthly data pulled from a handful of reports based on the party name for that file.
- Also record the data from the each file's new sheet on the main macro sheet for a summary and audit purposes.
- Currently commented out, but one of the next sections I want to poke at - if it doesn't already exist, add a sheet for Historical data for each file, then for all add in a column of data for that month's new data and update a rolling 12 month average number. I've also commented out the intent of checking each source report for filtered data when opening so that doesn't risk causing errors.
- Do for all files in the specified folder, then save the summary page as a record to pdf (audit purposes) and xlsx (review, etc.).
Again, this works, it's just clunky, and I know there has to be better ways to do this sort of thing.
Dim RiskWB As Workbook 'Macro workbook
Dim RiskWS As Worksheet 'File/folder details sheet in Macro workbook
Dim WS As Worksheet
Dim AtoCWS As Worksheet
Dim CtoSWS As Worksheet
Dim AtoSWS As Worksheet
Dim AtoCName As String
Dim AtoC As Workbook
Dim RWB As Workbook
Dim RName As String
Dim RWS As Worksheet
Dim External As Worksheet
Dim ExternalName As String
Dim ExternalWB As Workbook
Dim HRWS As Worksheet
Dim HRName As String
Dim HRWB As Workbook
Dim AddlWB As Workbook
Dim AddlWS As Worksheet
Dim AddlName As String
Dim FolderPath As String
Dim ReportPath As String
Dim Files As Workbook 'partner files in FolderPath
Dim loopFolder As String
Dim fileNm As Variant
Dim myFiles As New Collection
Dim t As Date
t = Now()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Set RiskWB = ThisWorkbook 'Macro workbook
Set RiskWS = RiskWB.Worksheets("Details for Macro")
Set RiskT = RiskWB.Worksheets("Template")
Set RiskH = RiskWB.Worksheets("Historical Data")
If Right((RiskWS.Range("B7").Value), 1) <> "\" Then
RiskWS.Range("B7").Value = RiskWS.Range("B7").Value & "\"
Else
End If
If Right((RiskWS.Range("B9").Value), 1) <> "\" Then
RiskWS.Range("B9").Value = RiskWS.Range("B9").Value & "\"
Else
End If
ReportPath = RiskWS.Range("B9") 'Folder path for report files
AtoCName = RiskWS.Range("B11") AtoC percentages file path and name
RName = RiskWS.Range("B12") 'R Log file name
ExternalName = RiskWS.Range("B13") 'External file name
HRName = RiskWS.Range("B14") 'High Risk audit findings file name
AddlName = RiskWS.Range("B15") 'Additional Partner Details file name
'Set Type = RiskWs.Range("B17") 'Initial or Update
Set AtoC = Workbooks.Open(AtoCName)
Set AtoCWS = AtoC.Sheets("AtoS")
' If AtoCWS.AutoFilterMode Then
' AtoCWS.AutoFilterMode = False
' End If
Set CtoSWS = AtoC.Sheets("CtoS")
' If CtoSWS.AutoFilterMode Then
' CtoSWS.AutoFilterMode = False
' End If
Set AtoSWS = AtoC.Sheets("AtoS")
' If AtoSWS.AutoFilterMode Then
' AtoSWS.AutoFilterMode = False
' End If
Set RWB = Workbooks.Open(RName)
Set RWS = RWB.Sheets("2023&2024")
' If RWS.AutoFilterMode Then
' RWS.AutoFilterMode = False
' End If
Set AddlWB = Workbooks.Open(AddlName)
Set AddlWS = AddlWB.Sheets("Sheet1")
' If AddlWS.AutoFilterMode Then
'AddlWS.AutoFilterMode = False
'End If
Set ExternalWB = Workbooks.Open(ExternalName)
Set External = ExternalWB.Sheets("Sheet1")
' If External.AutoFilterMode Then
' External.AutoFilterMode = False
' End If
Set HRWB = Workbooks.Open(HRName)
Set HRWS = HRWB.Sheets(1)
' If HRWS.AutoFilterMode Then
' HRWS.AutoFilterMode = False
'End If
RiskWS.Range("B20").Value = Application.UserName
RiskWS.Range("B19").Value = Now
loopFolder = RiskWS.Range("B7").Value 'Folder path for existing files
fileNm = Dir(loopFolder & "*.xlsx")
LR = RiskWS.Cells(Rows.Count, 1).End(xlUp).Row
Do While fileNm <> ""
myFiles.Add fileNm
fileNm = Dir
Loop
Dim wb As Workbook
On Error Resume Next
For Each fileNm In myFiles
Set wb = Workbooks.Open(Filename:=(loopFolder & fileNm))
wb.Unprotect Password:="*************"
RiskT.Copy Before:=wb.Sheets(1)
Set SCard = wb.ActiveSheet
SCard.Name = RiskWS.Range("C4").Value
SCard.Range("A2").Value = Left(fileNm, InStr(fileNm, "_") - 1)
SCard.Range("B2").Value = "Date: " & Format(Date, "m/d/yyyy")
RLR = AtoCWS.Cells(AtoCWS.Rows.Count, "R").End(xlUp).Row
Set WBN = SCard.Range("A2")
Set A2CName = AtoCWS.Range("Q:Q")
Set A2C = AtoCWS.Range("D:D")
Set A2CRev = AtoCWS.Range("C:C")
Set A2CMin = RiskT.Range("F52")
If Application.WorksheetFunction.XLookup(WBN, A2CName, A2C) = "N/A" Then
Resume Next
Else
If Application.WorksheetFunction.XLookup(WBN, A2CName, A2CRev) < A2CMin Then
Resume Next
Else
SCard.Range("B3") = Application.WorksheetFunction.XLookup(WBN, A2CName, A2C)
End If
End If
On Error Resume Next
Dim RiskP As Worksheet
Set RiskP = RiskWB.Worksheets("Partner List")
PName = RiskP.Range("C:C")
PNotes = RiskP.Range("A:A")
Set C2SName = CtoSWS.Range("Q:Q")
Set C2S = CtoSWS.Range("D:D")
If Application.WorksheetFunction.XLookup(WBN, PName, PNotes) = "ABC" Then
SCard.Range("E4") = "ABC"
SCard.Range("B4") = Application.WorksheetFunction.XLookup(WBN, C2SName, C2S)
'Else
If Application.WorksheetFunction.XLookup(WBN, PName, PNotes) = "ABC & Red" Then
SCard.Range("E4") = "ABC"
'Else
SCard.Range("B4") = Application.WorksheetFunction.XLookup(WBN, C2SName, C2S)
If Application.WorksheetFunction.XLookup(WBN, C2SName, C2S) = "N/A" Then
Resume Next
End If
End If
Else
Set A2SName = AtoSWS.Range("Q:Q")
Set A2S = AtoSWS.Range("D:D")
Set A2SRev = AtoSWS.Range("B:B")
Set A2SMin = RiskT.Range("F56")
If Application.WorksheetFunction.XLookup(WBN, A2SName, A2S) = "N/A" Then
Resume Next
Else
If Application.WorksheetFunction.XLookup(WBN, A2SName, A2SRev) < A2SMin Then
Resume Next
Else
SCard.Range("B4") = Application.WorksheetFunction.XLookup(WBN, A2SName, A2S)
End If
End If
On Error Resume Next
End If
Set RWBPartner = RWS.Range("G:G")
Set RWBStatus = RWS.Range("I:I")
Set RWBMin = RiskT.Range("F57")
Dim RWBC As Long
RWBC = WorksheetFunction.Sum(Application.WorksheetFunction.CountIfs(RWBPartner, WBN, RWS.Range("I:I"), "No Response")) + (Application.WorksheetFunction.CountIfs(RWBPartner, WBN, RWS.Range("I:I"), "Response Provided"))
If RWBC < RWBMin Then
Resume Next
Else
SCard.Range("B5") = WorksheetFunction.Sum(WorksheetFunction.CountIfs(RWS.Range("G:G"), WBN, RWS.Range("I:I"), "No Response") / RWBC)
End If
SCard.Range("B6") = WorksheetFunction.CountIf(External.Range("N:N"), WBN)
'On Error Resume Next
Set HRPartnerName = HRWS.Range("K:K")
Set HRF = HRWS.Range("C:C")
SCard.Range("B8") = WorksheetFunction.CountIfs(HRWS.Range("K:K"), WBN, HRWS.Range("C:C"), "High*", HRWS.Range("F:F"), "<>" & "Yes")
SCard.Range("B9") = WorksheetFunction.CountIfs(HRWS.Range("K:K"), WBN, HRWS.Range("C:C"), "High*", HRWS.Range("E:E"), "Yes", HRWS.Range("F:F"), "<>" & "Yes")
'On Error Resume Next
Set AddlPName = AddlWS.Range("A:A")
Set ODC = AddlWS.Range("B:B")
If Application.WorksheetFunction.XLookup(WBN, AddlPName, ODC) = 0 Then
SCard.Range("B10") = "0"
Else
SCard.Range("B10") = Application.WorksheetFunction.XLookup(WBN, AddlPName, ODC)
End If
Set Unfund = AddlWS.Range("C:C")
If Application.WorksheetFunction.XLookup(WBN, AddlPName, Unfund) = 0 Then
SCard.Range("B11") = "No"
Else
SCard.Range("B11") = Application.WorksheetFunction.XLookup(WBN, AddlPName, Unfund)
End If
Set Overdue = AddlWS.Range("D:D")
If Application.WorksheetFunction.XLookup(WBN, AddlPName, Overdue) = 0 Then
SCard.Range("B12") = "Low"
Else
If Application.WorksheetFunction.XLookup(WBN, AddlPName, Overdue) = "Low" Then
SCard.Range("B12") = "Low"
Else
SCard.Range("B12") = Application.WorksheetFunction.XLookup(WBN, AddlPName, Overdue)
End If
End If
Set OpenHM = AddlWS.Range("E:E")
If Application.WorksheetFunction.XLookup(WBN, AddlPName, OpenHM) = 0 Then
SCard.Range("B13") = "Low"
Else
SCard.Range("B13") = Application.WorksheetFunction.XLookup(WBN, AddlPName, OpenHM)
End If
Set EDR = AddlWS.Range("F:F")
If Application.WorksheetFunction.XLookup(WBN, AddlPName, EDR) = 0 Then
SCard.Range("B14") = "No"
Else
SCard.Range("B14") = Application.WorksheetFunction.XLookup(WBN, AddlPName, EDR)
End If
Set Mystery = AddlWS.Range("G:G")
If Application.WorksheetFunction.XLookup(WBN, AddlPName, Mystery) = 0 Then
SCard.Range("B15") = "0"
Else
SCard.Range("B15") = Application.WorksheetFunction.XLookup(WBN, AddlPName, Mystery)
End If
If Application.WorksheetFunction.XLookup(WBN, PName, PNotes) = "Red" Then
SCard.Range("C20") = "Red"
If Application.WorksheetFunction.XLookup(WBN, PName, PNotes) = "ABC & Red" Then
SCard.Range("C20") = "Red"
End If
Else
Resume Next
End If
RiskWS.Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = SCard.Range("A2").Value
RiskWS.Cells(Rows.Count, "B").End(xlUp).Offset(1).Value = SCard.Range("B3").Value
RiskWS.Cells(Rows.Count, "C").End(xlUp).Offset(1).Value = SCard.Range("B4").Value
RiskWS.Cells(Rows.Count, "D").End(xlUp).Offset(1).Value = SCard.Range("B5").Value
RiskWS.Cells(Rows.Count, "E").End(xlUp).Offset(1).Value = SCard.Range("B6").Value
RiskWS.Cells(Rows.Count, "F").End(xlUp).Offset(1).Value = SCard.Range("B8").Value
RiskWS.Cells(Rows.Count, "G").End(xlUp).Offset(1).Value = SCard.Range("B9").Value
RiskWS.Cells(Rows.Count, "H").End(xlUp).Offset(1).Value = SCard.Range("B10").Value
RiskWS.Cells(Rows.Count, "I").End(xlUp).Offset(1).Value = SCard.Range("B11").Value
RiskWS.Cells(Rows.Count, "J").End(xlUp).Offset(1).Value = SCard.Range("B12").Value
RiskWS.Cells(Rows.Count, "K").End(xlUp).Offset(1).Value = SCard.Range("B13").Value
RiskWS.Cells(Rows.Count, "L").End(xlUp).Offset(1).Value = SCard.Range("B14").Value
RiskWS.Cells(Rows.Count, "M").End(xlUp).Offset(1).Value = SCard.Range("B15").Value
RiskWS.Cells(Rows.Count, "N").End(xlUp).Offset(1).Value = SCard.Range("C16").Value
RiskWS.Cells(Rows.Count, "N").End(xlUp).Offset(0, 1).Value = SCard.Range("C20").Value
On Error Resume Next
DoEvents
'Create historical data tab if does not already exist and add base format (save as template in macro file?)
'Set RiskH = RiskWB.Worksheets("Historical Data")
'Dim HistoricalWS As Worksheet
'Dim SheetExists As Boolean
'SheetExists = False
'For Each WS In WB.Worksheets
'If WS.Name = "Historical Data" Then
' SheetExists = True
' Else
'End If
'Next
' If SheetExists = False Then
' RiskH.Copy Before:=WB.Sheets(1)
' Set HistoricalWS = WB.ActiveSheet
' Set HistoricalWS = WB.ActiveSheet
' HistoricalWS.Name = "Historical Data"
' HistoricalWS.Range("A1").Value = WBN
' End If
' HistoricalWS.Range("C:C").Insert
' HistoricalWS.Range("C1").Value = RiskWS.Range("C4").Value
' HistoricalWS.Range("C2").Value = SCard.Range("B3").Value
'HistoricalWS.Range("C3").Value = SCard.Range("B4").Value
'HistoricalWS.Range("C4").Value = SCard.Range("B5").Value
' HistoricalWS.Range("C5").Value = SCard.Range("B6").Value
' HistoricalWS.Range("C6").Value = SCard.Range("B7").Value
' HistoricalWS.Range("C7").Value = SCard.Range("B8").Value
' HistoricalWS.Range("C8").Value = SCard.Range("B9").Value
' HistoricalWS.Range("C9").Value = SCard.Range("B10").Value
' HistoricalWS.Range("C10").Value = SCard.Range("B11").Value
' HistoricalWS.Range("C11").Value = SCard.Range("B12").Value
' HistoricalWS.Range("C12").Value = SCard.Range("B13").Value
' HistoricalWS.Range("C13").Value = SCard.Range("B14").Value
' HistoricalWS.Range("C14").Value = SCard.Range("B15").Value
' HistoricalWS.Range("C15").Value = SCard.Range("D16").Value
' Worksheets("Historical Data").Move Before:=Worksheets(1)
DoEvents
wb.Protect Password:="************"
wb.Save
wb.Close
Next fileNm
AtoC.Close SaveChanges:=False
RWB.Close SaveChanges:=False
ExternalWB.Close SaveChanges:=False
HRWB.Close SaveChanges:=False
AddlWB.Close SaveChanges:=False
Last = RiskWS.Cells(Rows.Count, 1).End(xlUp).Row
Dim Report As Range
Set Report = Range("A23:O" & Last)
With Report.Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
RiskWS.Range("B3:C15").Interior.ColorIndex = xlNone
DoEvents
RiskWS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ReportPath & "BlahBlah Details - " & RiskWS.Range("C4").Value & " - " & Format(Date, "mm-dd-yyyy") & ".pdf"
SavePath = ReportPath & "BlahBlah Details - " & RiskWS.Range("C4").Value & " - " & Format(Date, "mm-dd-yyyy") & ".xlsx"
RiskWS.Copy
Set NewWB = ActiveWorkbook
NewWB.SaveAs Filename:=SavePath
NewWB.Close
RiskWS.Range("B3:B5").Interior.Color = RGB(255, 255, 0)
RiskWS.Range("C5").Interior.Color = RGB(255, 255, 0)
RiskWS.Range("B7").Interior.Color = RGB(255, 255, 0)
RiskWS.Range("B9").Interior.Color = RGB(255, 255, 0)
RiskWS.Range("B11:B17").Interior.Color = RGB(255, 255, 0)
RiskWS.Range("B19:B20").Value = ""
RiskWS.Range("A24:O" & Last).ClearContents
Report.Borders.LineStyle = None
RiskWS.Range("A23:O23").Borders(xlEdgeBottom).LineStyle = xlContinuous
'DoEvents
RiskWS.Range("A1").Activate
ActiveWorkbook.Save
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
MsgBox "Your files have been updated and saved!" & vbCrLf & "Elapsed Time: " & Format(Now() - t, "hh:mm:ss"), vbOKOnly, "Woohoo!"
End Sub
Application.Calculation = xlCalculationManualwould be more efficient but you'll have to make sure that it is doesn't change the result. Are you adding a new row toRiskWS? \$\endgroup\$