将多个工作表中的数据编译到单个工作簿中的主工作表 - 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完成的。