將多個工作表中的數據編譯到單個工作簿中的主工作表 - VBA Excel 宏

Question

問題：如何讓這個宏運行得更快？

我將數據下載到一個工作簿中。 數據由變量列表（a 列中的字符串）及其值（b 列中的字符串或數字）組成。 所有“可能的”配置變量都存在於主工作表中。 每個工作表共享一些變量，但不是全部，並且可能有一個唯一的變量需要添加到變量主列表中。 我使用這個宏在一個主工作表中編譯數據：

Sub CompareVariableData()

Dim mainws As Worksheet *'establishes worksheet variable*
Set mainws = Worksheets(1) *'sets mainws as the master for comparison*
Dim wscount As Long *'counts total number of worksheets in the workbook*
Dim curwsnum As Long *'tracks the current worksheet being compared*
wscount = ActiveWorkbook.Worksheets.Count *'gives wscount a value equal to the number of     worksheets*

For curwsnum = 2 To wscount *'loop from the second worksheet to the last active worksheet*
Dim r As Long *'variable for row in the compared worksheet*
Dim mainwsrow As Long *'variable counter for rows in the master worksheet*


mainws.Cells(1, curwsnum) = Worksheets(curwsnum).Name *'adds the name of the compared worksheet to first row of the first worksheet*

 For r = 3 To Worksheets(curwsnum).Range("A" & Rows.Count).End(xlUp).Row *'loops from the third row of compared worksheet to the last used row*

    curstr = Worksheets(curwsnum).Cells(r, 1) *'creates a variable curstr that will capture the variable name from the first column*

    mainws.Activate *'activates the main ws for the next loop*

 If Not IsError(Application.Match(curstr, mainws.Columns("A:A"), 0)) Then *'if there is no error in a match between the compare variable and master variable list*
    *'found*
    mainws.Cells(Application.Match(curstr, mainws.Columns("A:A"), 0), curwsnum) = Worksheets(curwsnum).Cells(r, 2) *'adds the value of the variable from the compare worksheet to the master worksheet*
 Else
    *'Not found*
    Dim lastrow As Long *'makes a variable lastrow to add a 'notfound' variable to the end of the master list*
    lastrow = mainws.Range("A" & Rows.Count).End(xlUp).Row + 1 *'finds the last row*

    mainws.Cells(lastrow, 1) = curstr *'adds the variable to the master list*
    mainws.Cells(lastrow, curwsnum) = Worksheets(curwsnum).Cells(r, 2) *'adds the value from the compared worksheet*
    mainws.Cells(lastrow, 1).Interior.Color = vbYellow *'highlights the row*
 End If
 Next

Next

End Sub

Answer 1

歡迎使用 StackOverflow。

對於未來的問題，您應該提供有關該問題的更多信息：例如，對於這個問題，您可能已經包含了您遇到的症狀（運行需要多長時間？），您已經嘗試解決的問題問題（你做了什么研究，有沒有幫助？），以及其他相關細節（比如你的數據集有多大？）。

以下所有內容均未使用您的代碼進行測試，但嘗試任何或所有這些都應該是安全的，假設您不重寫以使用字典，正如 Tim 建議的那樣：

1. 正如 Tim Williams 上面建議的那樣，在代碼的開頭使用Application.ScreenUpdating = False和Application.Calculation = xlCalculationManual 。 最后一定要重新打開這些。
2. 將r 、 mainwsrow和lastrow的dim語句移出循環（因此它們只被lastrow一次，而不是每個循環）。
3. 顯式維度curstr ：強輸入此變量應該有助於提高性能，因為它當前未變暗並且默認為變體（如果我正確閱讀，這將始終在您的數據集中返回一個字符串）
4. 消除mainws.Activate 。 激活和選擇項目總是需要額外的時間，此外我認為您的代碼不需要它，因為它是編寫的。

您生成的代碼可能如下所示：

    Dim mainws As Worksheet
        Set mainws = Worksheets(1)
    Dim wscount As Long
        wscount = ActiveWorkbook.Worksheets.Count
    Dim curwsnum As Long
'~~>Move the following from within the loop structures
    Dim r As Long
    Dim mainwsrow As Long
    Dim lastrow As Long
'~~>Add to strongly type this variable
    Dim curstr As String
'~~>Add to track initial Calculation Method for restoring the same value
    Dim msCalcState As String
        msCalcState = Application.Calculation

'~~>Turn off Updates during code run
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

        For curwsnum = 2 To wscount
            mainws.Cells(1, curwsnum) = Worksheets(curwsnum).Name
            For r = 3 To Worksheets(curwsnum).Range("A" & Rows.Count).End(xlUp).Row
'~~>Remove mainws.Activate
                curstr = Worksheets(curwsnum).Cells(r, 1)
                If Not IsError(Application.Match(curstr, mainws.Columns("A:A"), 0)) _
                Then
                    mainws.Cells(Application.Match(curstr, mainws.Columns("A:A"), _
                        0), curwsnum) = Worksheets(curwsnum).Cells(r, 2)
                Else
                    lastrow = mainws.Range("A" & Rows.Count).End(xlUp).Row + 1
                    mainws.Cells(lastrow, 1) = curstr
                    mainws.Cells(lastrow, curwsnum) = Worksheets(curwsnum).Cells(r, 2)
                    mainws.Cells(lastrow, 1).Interior.Color = vbYellow
                End If
            Next r
        Next curwsnum

'~~>Restore Update settings
    Application.ScreenUpdating = True
    Application.Calculation = msCalcState

那應該讓你分道揚鑣。

Answer 2

如何將每個非主表VLOOKUP()到主表（檢查那里是否存在變量）然后按找到的值排序，最后會發現錯誤，然后將它們復制到主表。
然后，在母版表中在列 2,3..wscount+1 中插入公式
IFERROR(VLOOKUP('variable', SheetN!$A$1:$B$x, 2, 0), "") - 這將查找現有變量的值。
最后在主表上使用 vlookup 復制范圍，然后將其粘貼為值 - 瞧，我認為這比逐個單元格檢查要快得多。
以上當然都是用VBA完成的。