Need help cleaning up my currently working code

Question

Just wondering if anyone can help me clean up my code. It currently works perfectly for what I need it to do. Just wondering if it can run faster. Right now it seems to open and close each workbook 3 times before moving to the next one.

Sub JanuaryMacro()
    Dim strF As String, strP As String
    Dim wb As Workbook

    Range("B2:M2").clearcontents
    'Edit this declaration to your folder name
    strP = "\\My path" 'change for the path of your folder

    strF = Dir(strP & "\*.xlsx")
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    Do While strF <> vbNullString

        Set wb = Workbooks.Open(strP & "\" & strF)

        Range("Totals").Select
        Selection.Copy
        Windows("Monthly Report.xlsm").Activate
        Range("D2:M2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
            :=False, Transpose:=False

        Set wb = Workbooks.Open(strP & "\" & strF)

        Range("FG_Approvals").Select
        Selection.Copy
        Windows("Monthly Report.xlsm").Activate
        Range("C2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
            :=False, Transpose:=False

        Set wb = Workbooks.Open(strP & "\" & strF)

        Range("Allocations").Select
        Selection.Copy
        Windows("Monthly Report.xlsm").Activate
        Range("B2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
            :=False, Transpose:=False

        wb.Close SaveChanges:=False

        strF = Dir()
    Loop

    Application.DisplayAlerts = True
End Sub

You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). — Pᴇʜ, Apr 09 '19 at 06:36
I'm voting to close this question as off-topic because this has no actual issue and it might better be a subject to https://codereview.stackexchange.com/ — Pᴇʜ, Apr 09 '19 at 06:38

Asger · Accepted Answer · 2019-04-09T06:13:03.480

You should use references to your monthly-report-sheet, the new workbook and its sheet e. g. like this:

Sub JanuaryMacroVersion2()
    Dim strF As String, strP As String
    Dim mr As Worksheet
    Dim wb As Workbook, ws As Worksheet

    Set mr = ActiveSheet  ' your monthly report
    mr.Range("B2:M2").ClearContents

    strP = "\\My path" 'change for the path of your folder
    strF = Dir(strP & "\*.xlsx")
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Do While strF <> vbNullString
        Set wb = Workbooks.Open(strP & "\" & strF)
        Set ws = ActiveSheet

        ws.Range("Totals").Copy
        mr.Range("D2:M2").PasteSpecial _
            Paste:=xlPasteValues, Operation:=xlAdd, _
            SkipBlanks:=False, Transpose:=False

        ws.Range("FG_Approvals").Copy
        mr.Range("C2").PasteSpecial _
            Paste:=xlPasteValues, Operation:=xlAdd, _
            SkipBlanks:=False, Transpose:=False

        ws.Range("Allocations").Copy
        mr.Range("B2").PasteSpecial _
            Paste:=xlPasteValues, Operation:=xlAdd, _
            SkipBlanks:=False, Transpose:=False

        wb.Close SaveChanges:=False
        strF = Dir()
    Loop
    Application.DisplayAlerts = True
End Sub

If the range names like "FG_Approvals" refer to a workbook wide name, replace ws.Range("FG_Approvals")by wb.Range("FG_Approvals").

Next optimization step would be omitting copy/paste by assigning their Range.Value directly:

Sub JanuaryMacroVersion3()
    Dim strF As String, strP As String
    Dim mr As Worksheet
    Dim wb As Workbook, ws As Worksheet
    Dim lastRow As Long

    Set mr = ActiveSheet
    mr.Range("B2:M2").ClearContents

    strP = "\\My path" 'change for the path of your folder
    strF = Dir(strP & "\*.xlsx")
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Do While strF <> vbNullString
        Set wb = Workbooks.Open(strP & "\" & strF)
        Set ws = ActiveSheet

        lastRow = mr.Cells(mr.Rows.Count, "D").End(xlUp).Row
        mr.Cells(lastRow + 1, "D").Resize _
            (ws.Range("Totals").Rows.Count, _
            ws.Range("Totals").Columns.Count).Value _
            = ws.Range("Totals").Value

        lastRow = mr.Cells(mr.Rows.Count, "C").End(xlUp).Row
        mr.Cells(lastRow + 1, "C").Resize _
            (ws.Range("FG_Approvals").Rows.Count, _
            ws.Range("FG_Approvals").Columns.Count).Value _
            = ws.Range("FG_Approvals").Value

        lastRow = mr.Cells(mr.Rows.Count, "B").End(xlUp).Row
        mr.Cells(lastRow + 1, "B").Resize _
            (ws.Range("Allocations").Rows.Count, _
            ws.Range("Allocations").Columns.Count).Value _
            = ws.Range("Allocations").Value

        wb.Close SaveChanges:=False
        strF = Dir()
    Loop
    Application.DisplayAlerts = True
End Sub

Excellent! Thank you so much! Working much faster now. And I'm sorry about posting a working script here... did not know where to ask for clean up help. I will try to remember in the future. — Winger156, Apr 09 '19 at 07:17

Need help cleaning up my currently working code

1 Answers1