0
\$\begingroup\$

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:

  1. Loop through folder of files to be updated.
  2. 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.
  3. Also record the data from the each file's new sheet on the main macro sheet for a summary and audit purposes.
  4. 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.
  5. 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
\$\endgroup\$
2
  • \$\begingroup\$ It would help to have some sample data. Application.Calculation = xlCalculationManual would be more efficient but you'll have to make sure that it is doesn't change the result. Are you adding a new row to RiskWS? \$\endgroup\$
    – TinMan
    Commented Mar 22 at 17:32
  • \$\begingroup\$ This monolithic block of highly-coupled code is Too Long. Recommend you learn how to use Subprograms. \$\endgroup\$
    – J_H
    Commented Apr 12 at 13:50

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.