Нужна помощь в очистке моего текущего рабочего кода

Question

Просто интересно, может ли кто-нибудь помочь мне очистить мой код.В настоящее время он отлично работает для того, что мне нужно сделать.Просто интересно, может ли он работать быстрее.Прямо сейчас кажется, что каждую книгу можно открыть и закрыть 3 раза, прежде чем перейти к следующей.

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

Answer 1

Вы должны использовать ссылки на свой ежемесячный отчетный лист, новую рабочую книгу и ее лист, например, вот так:

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

Если имена диапазонов, такие как "FG_Approvals", относятся к общему имени рабочей книги, заменитеws.Range("FG_Approvals") на wb.Range("FG_Approvals").

---

Следующим шагом оптимизации будет исключение копирования / вставки путем назначения их Range.Value напрямую:

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