如何优化 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

刚刚去掉了一些选择语句，添加了一些循环，并在执行时关闭了屏幕更新并将计算设置为手动。我在这里和那里添加了一些 cmets，也检查一下。看看有没有帮助

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