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

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

1 个答案: