如何优化VBA代码以更快地运行

Question

我需要有人救我这个。我不是开发人员;我是QA。但是，我的任务是创建一个脚本，该脚本将从一个xlsx获取海量数据，并根据销售人员，客户和分支位置创建新的xlsx文档。我有代码工作，但如果它运行的计算机没有内存不足，它将需要几天时间运行。我将发布下面的代码。有没有什么方法可以优化它以便更快地运行？星期五早上我们需要它。让我重申一下，我是QA。如果你说这样做或那样做，我不知道你在说什么。我真的需要“用这个代替”。到目前为止，你们在帮助方面都非常棒，我不能够感谢你们。我不知道你为什么做你做的事，但是谢谢你这样做。

Option Explicit

' get a named worksheet from specified workbook, creating it if required
Public Function GetSheet(ByVal Name As String, ByVal Book As Workbook, Optional ByVal Ignore As Boolean = False) As Worksheet
Dim Sheet As Worksheet
Dim Key As String
Dim Result As Worksheet: Set Result = Nothing

    Key = UCase(Name)

    ' loop over all the worksheets
    For Each Sheet In Book.Worksheets
        ' break out of the loop if the sheet is found
        If UCase(Sheet.Name) = Key Then
            Set Result = Sheet
            Exit For
        End If
    Next Sheet

    ' if the sheet isn't found..
    If Result Is Nothing Then
        If Ignore = False Then
            If Not GetSheet("Sheet1", Book, True) Is Nothing Then
                ' rename sheet1
                Set Result = Book.Worksheets("Sheet1")
                Result.Name = Name
            End If
        Else
            ' create a new sheet
            Set Result = Book.Worksheets.Add
            Result.Name = Name
        End If
        Result.Cells(1, 1) = "Rank"
        Result.Cells(1, 2) = "Customer Segment"
        Result.Cells(1, 3) = "Salesrep Name"
        Result.Cells(1, 4) = "Main_Customer_NK"
        Result.Cells(1, 5) = "Customer"
        Result.Cells(1, 6) = "FY13 Sales"
        Result.Cells(1, 7) = "FY13 Inv Cost GP$"
        Result.Cells(1, 8) = "FY13 Inv Cost GP%"
        Result.Cells(1, 9) = "Sales Growth"
        Result.Cells(1, 10) = "GP Point Change"
        Result.Cells(1, 11) = "Sales % Increase"
        Result.Cells(1, 12) = "Budgeted Total Sales"
        Result.Cells(1, 13) = "Budget GP%"
        Result.Cells(1, 14) = "Budget GP$"
        Result.Cells(1, 15) = "Target Account"
        Result.Cells(1, 16) = "Estimated Total Purchases"
        Result.Cells(1, 17) = "Estimated Sales Calls Monthly"
        Result.Cells(1, 18) = "Notes"
        Result.Cells(1, 19) = "Reference 1"
        Result.Cells(1, 20) = "Reference 2"

        'and the rest....
    End If

    Set GetSheet = Result

End Function


Sub Main()
Dim Source As Worksheet
Dim Location As Workbook
Dim Sales As Worksheet
Dim LocationKey As String
Dim SalesKey As String
Dim Index As Variant
Dim Map As Object: Set Map = CreateObject("Scripting.Dictionary")
Dim Row As Long
Dim InsertPos As Long

    Set Source = ThisWorkbook.ActiveSheet

    Row = 2 ' Skip header row

    Do
        ' break out of the loop - assumes that the first empty row signifies the end
        If Source.Cells(Row, 1).Value2 = "" Then
            Exit Do
        End If

        LocationKey = Source.Cells(Row, 3).Value2

        ' look at the location, and find the workbook, creating it if required
        If Map.Exists(LocationKey) Then
            Set Location = Map(LocationKey)
        Else
            Set Location = Application.Workbooks.Add(xlWBATWorksheet)
            Map.Add LocationKey, Location
        End If

        SalesKey = Source.Cells(Row, 5).Value2

        ' get the sheet for the salesperson
        Set Sales = GetSheet(SalesKey, Location)

        ' Get the location to enter the data
        InsertPos = Sales.Range("A1").End(xlDown).Row + 1



        'check to see if it's a new sheet, and adjust
        If InsertPos = 1048577 Then
        'Stop
            InsertPos = 2
            'change to 65537 is using excel 2003 or before
            Macro1
        End If

        ' populate said row with the data from the source
        Sales.Cells(InsertPos, 1).Value2 = Source.Cells(Row, 1)
        Sales.Cells(InsertPos, 2).Value2 = Source.Cells(Row, 2)
        Sales.Cells(InsertPos, 3).Value2 = Source.Cells(Row, 5)
        Sales.Cells(InsertPos, 4).Value2 = Source.Cells(Row, 6)
        Sales.Cells(InsertPos, 5).Value2 = Source.Cells(Row, 7)
        Sales.Cells(InsertPos, 6).Value2 = Source.Cells(Row, 8)
        Sales.Cells(InsertPos, 7).Value2 = Source.Cells(Row, 9)
        Sales.Cells(InsertPos, 8).Value2 = Source.Cells(Row, 10)
        Sales.Cells(InsertPos, 9).Value2 = Source.Cells(Row, 11)
        Sales.Cells(InsertPos, 10).Value2 = Source.Cells(Row, 12)
        Sales.Cells(InsertPos, 11).Value2 = Source.Cells(Row, 13)
        Sales.Cells(InsertPos, 12).Value2 = Source.Cells(Row, 14)
        Sales.Cells(InsertPos, 13).Value2 = Source.Cells(Row, 15)
        Sales.Cells(InsertPos, 14).Value2 = Source.Cells(Row, 16)
        Sales.Cells(InsertPos, 19).Value2 = Source.Cells(Row, 17)
        Sales.Cells(InsertPos, 20).Value2 = Source.Cells(Row, 18)
        Sales.Range("L" & InsertPos).Formula = "=(F2*K2)+F2"
        Sales.Range("N" & InsertPos).Formula = "=(M2+H2)*L2"

        'increment the loop



        'Range("H" & InsertPos).Activate
        'If Range("F" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (100 * Range("G" & InsertPos) / Range("F" & InsertPos))

        'Range("I" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("F" & InsertPos) / Range("S" & InsertPos) - 1)

        'Range("J" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("T" & InsertPos) / Range("S" & InsertPos))

        Row = Row + 1

        Macro2 'runs on each cell
    Loop


    ' loop over the resulting workbooks and save them - using the location name as file name
    For Each Index In Map.Keys

          Set Location = Map(Index)

        Location.SaveAs Filename:=Index
    Next Index

End Sub

Sub Macro1()
'
' Macro1 Macro
'

'
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("F:G").Select
    Selection.NumberFormat = "$#,##0.00"
    ActiveWindow.SmallScroll ToRight:=3
    Columns("H:J").Select
    Selection.NumberFormat = "0.00%"
    Selection.NumberFormat = "0.0%"
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    Range("K:K,M:M").Select
    Range("M1").Activate
    Selection.NumberFormat = "0.0%"
    Range("N:N,L:L").Select
    Range("L1").Activate
    Selection.NumberFormat = "$#,##0.00"
    ActiveWindow.SmallScroll ToRight:=5
    Columns("S:T").Select
    Selection.EntireColumn.Hidden = True
    ActiveWindow.SmallScroll ToRight:=-4
    Range("K:K,M:M").Select
    Range("M1").Activate
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Cells.Select
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Range("L9").Activate
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Cells.EntireColumn.AutoFit
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

End Sub

Sub Macro2()
'
' Macro2 Macro
'

'
    Cells.EntireColumn.AutoFit
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        14, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub

Answer 1

刚刚删除了一些select语句，添加了一些循环，关闭了屏幕更新，并在执行时将计算设置为手动。我已经在这里和那里添加了一些评论，也可以查看它们。看看是否有帮助

Option Explicit

Sub Main()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

    Dim Source As Worksheet
    Dim Location As Workbook
    Dim Sales As Worksheet
    Dim LocationKey As String
    Dim SalesKey As String
    Dim Index As Variant
    Dim Map As Object: Set Map = CreateObject("Scripting.Dictionary")
    Dim Row As Long
    Dim InsertPos As Long

    Set Source = ThisWorkbook.ActiveSheet

    Row = 2 ' Skip header row

    Do
        ' break out of the loop - assumes that the first empty row signifies the end
        If Source.Cells(Row, 1).Value2 = "" Then
            Exit Do
        End If

        LocationKey = Source.Cells(Row, 3).Value2

        ' look at the location, and find the workbook, creating it if required
        If Map.Exists(LocationKey) Then
            Set Location = Map(LocationKey)
        Else
            Set Location = Application.Workbooks.Add(xlWBATWorksheet)
            Map.Add LocationKey, Location
        End If

        SalesKey = Source.Cells(Row, 5).Value2

        ' get the sheet for the salesperson
        Set Sales = GetSheet(SalesKey, Location)

        ' Get the location to enter the data
        InsertPos = Sales.Range("A1").End(xlDown).Row + 1

        'check to see if it's a new sheet, and adjust
        If InsertPos = 1048577 Then
        'Stop
            InsertPos = 2
            'change to 65537 is using excel 2003 or before
            Macro1
        End If

        ' populate said row with the data from the source
        Dim i As Long
        For i = 1 To 2
            Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i)
        Next i
        For i = 3 To 14
            Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i + 2)
        Next i
        For i = 19 To 20
            Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i - 2)
        Next i
        Sales.Range("L" & InsertPos).Formula = "=(F2*K2)+F2"
        Sales.Range("N" & InsertPos).Formula = "=(M2+H2)*L2"


        'increment the loop
        'Range("H" & InsertPos).Activate
        'If Range("F" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (100 * Range("G" & InsertPos) / Range("F" & InsertPos))

        'Range("I" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("F" & InsertPos) / Range("S" & InsertPos) - 1)

        'Range("J" & InsertPos).Activate
        'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("T" & InsertPos) / Range("S" & InsertPos))

        Row = Row + 1

        Macro2 'runs on each cell
    Loop


    ' loop over the resulting workbooks and save them - using the location name as file name
    For Each Index In Map.Keys
        Set Location = Map(Index)
        Location.SaveAs Filename:=Index
    Next Index

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub


' get a named worksheet from specified workbook, creating it if required
Public Function GetSheet(ByVal Name As String, ByVal Book As Workbook, Optional ByVal Ignore As Boolean = False) As Worksheet
    Dim Sheet As Worksheet
    Dim Key As String
    Dim Result As Worksheet: Set Result = Nothing

    Key = UCase(Name)

    ' loop over all the worksheets
    For Each Sheet In Book.Worksheets
        ' break out of the loop if the sheet is found
        If UCase(Sheet.Name) = Key Then
            Set Result = Sheet
            Exit For
        End If
    Next Sheet

    ' if the sheet isn't found..
    If Result Is Nothing Then
        If Ignore = False Then
            If Not GetSheet("Sheet1", Book, True) Is Nothing Then
                ' rename sheet1
                Set Result = Book.Worksheets("Sheet1")
                Result.Name = Name
            End If
        Else
            ' create a new sheet
            Set Result = Book.Worksheets.Add
            Result.Name = Name
        End If

        Dim arr
        arr = Array("Rank", "Customer Segment", "Salesrep Name", "Main_Customer_NK", "Customer", "FY13 Inv Cost GP$", "FY13 Inv Cost GP%", "Sales Growth", "GP Point Change", "Sales % Increase", _
                    "Budgeted Total Sales", "Budget GP%", "Budget GP$", "Target Account", "Estimated Total Purchases", "Estimated Sales Calls Monthly", "Notes", "Reference 1", "Reference 2")

        Dim i As Long
        For i = LBound(arr) To UBound(arr)
            Result.Cells(1, i + 1) = arr(i)
        Next i

        ' stick the rest in the arr variable and you dont need the below anymore
        'Result.Cells(1, 1) = "Rank"
        'Result.Cells(1, 2) = "Customer Segment"
        'Result.Cells(1, 3) = "Salesrep Name"
        'Result.Cells(1, 4) = "Main_Customer_NK"
        'Result.Cells(1, 5) = "Customer"
        'Result.Cells(1, 6) = "FY13 Sales"
        'Result.Cells(1, 7) = "FY13 Inv Cost GP$"
        'Result.Cells(1, 8) = "FY13 Inv Cost GP%"
        'Result.Cells(1, 9) = "Sales Growth"
        'Result.Cells(1, 10) = "GP Point Change"
        'Result.Cells(1, 11) = "Sales % Increase"
        'Result.Cells(1, 12) = "Budgeted Total Sales"
        'Result.Cells(1, 13) = "Budget GP%"
        'Result.Cells(1, 14) = "Budget GP$"
        'Result.Cells(1, 15) = "Target Account"
        'Result.Cells(1, 16) = "Estimated Total Purchases"
        'Result.Cells(1, 17) = "Estimated Sales Calls Monthly"
        'Result.Cells(1, 18) = "Notes"
        'Result.Cells(1, 19) = "Reference 1"
        'Result.Cells(1, 20) = "Reference 2"

        'and the rest....
    End If

    Set GetSheet = Result
End Function



Sub Macro1()
    ' avoid using Select
    Columns.AutoFit
    Columns("F:G").NumberFormat = "$#,##0.00"
    Columns("H:J").NumberFormat = "0.0%"
    Range("K:K,M:M").NumberFormat = "0.0%"
    Range("N:N,L:L").NumberFormat = "$#,##0.00"
    Columns("S:T").EntireColumn.Hidden = True
    With Range("K:K,M:M").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Range("L9").Activate
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    'Cells.Select
    'Cells.EntireColumn.AutoFit
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        '14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

End Sub

Sub Macro2()

    Columns.AutoFit
    'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
        14, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub