需要帮助清理我当前工作的代码

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

您应该使用对您的月度报告表、新工作簿及其表 e 的引用。 G。像这样：

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