将多个工作表中的数据编译到单个工作簿中的主工作表 - VBA Excel 宏

Question

Question: How can I make this macro run faster?

I download data into a single workbook. The data is made up of a list of variables (string in column a) and their values (string or number in column b). All "possible" configuration variables exist in a master worksheet. Each worksheet shares some variables, but not all, and may have a unique variable that needs to be added to the variable master list. I compile the data in one master worksheet using this macro:

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

Welcome to StackOverflow.

For future questions you should give a bit more information on the problem: for this one, for example, you might have included the symptom you're having (How long does it take to run?), what you've tried already to solve the problem (what research did you do, and did any of it help?), and other relevant details (like how big is your data set?).

None of the below is tested with your code, but it all should be safe to try any or all of these, assuming that you don't rewrite to use a dictionary, as Tim suggests:

1. As Tim Williams suggests above, use Application.ScreenUpdating = False and Application.Calculation = xlCalculationManual at the start of your code. Be sure to turn these back on at the end.
2. Move the dim statments for r , mainwsrow and lastrow out of the loops (so they are only dimensioned once, and not with every loop).
3. Explicitly dimension curstr : strongly typing this variable should help with performance since it is currently un-Dimmed and would default to a variant (if I read correctly, this will always return a string in your data set)
4. Eliminating mainws.Activate . Activating and Selecting items always takes extra time, and besides I don't think your code needs it as it is written.

Your resulting code might look something like this:

    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

That should get you part way there.

Answer 2

How about adding on each non-master sheet VLOOKUP() to master sheet (checking if variable exists there) then sort by value found, errors will be found at the end, then copy them to master sheet.
Then, in master sheet inserting formulas in columns 2,3..wscount+1
IFERROR(VLOOKUP('variable', SheetN!$A$1:$B$x, 2, 0), "") - this will find values of existing variables.
Finally copy range with vlookup on master sheet then paste it as values - voila, I think it would be much faster than checking cell by cell.
All above done with VBA of course.