VBA - 使用字典的“For”循环优化

Question

最初，我的代码在标题中使用了数据过滤器，并循环遍历特定行中的每个条件，将该工作表上的所有可见数据复制并粘贴到各个相应的工作表中。我觉得这太初级了，在 SO 的一些帮助下，编写了如下所示的新代码。由于我不确定的原因，我的宏现在挂起 5-10 分钟来处理数据。与需要大约 10-15 秒的数据过滤方法相比。通常我的工作表少于 1000 行。但我们只是说，绝对最坏的情况，它不超过 2000 行。

每行包含大约 50 个连续的文本单元格，其中一些单元格的内部用颜色填充，50 个中的大约 10 个具有精确或简单的 SUM 公式。

如果有人有任何指示我应该改变什么可以加快速度，那就太好了！或者，如果您认为数据过滤方法是最好的。

Const TERR As String = "NA,AU,BR,CAen,CAfr,DE,ES,FR,IT,MX,USA,UK"

Sub CATsplit(wb2)
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wbMacro As ThisWorkbook
Dim dict As New Scripting.Dictionary
Dim t As Variant
Dim newSheet As Worksheet
Dim LC As Long


LC = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column



       For Each t In Split(TERR, ",")
        ' Create each sheet
          Set newSheet = Sheets.Add(after:=ActiveSheet)
              newSheet.Name = t
       With newSheet
            dict.Add t, .Cells(.Rows.Count, 2).End(xlUp).Row
       End With
       Next

Sheets("NA").Name = "No Result"
Sheet(1).Activate

For r = 2 To LR Step 1


 If Application.WorksheetFunction.IsNA(Sheets(1).Range("K" & r)) Then
        Range(Cells(r, 1), Cells(r, LC)).Copy Destination:=Sheets("No Result").Cells(dict("NA") + 1, 1)
        dict("NA") = Sheets("NA").Cells(Rows.Count, "B").End(xlUp).Row
        GoTo Nxt

 End If


 If Sheets(1).Range(Cells(r, 14)).Value = "Australia" Then

        Range(Cells(r, 1), Cells(r, LC)).Copy Destination:=Sheets("AU").Cells(dict("AU") + 1, 1)
        dict("AU") = Sheets("AU").Cells(Rows.Count, "B").End(xlUp).Row
        GoTo Nxt
    End If


If Sheets(1).Range(Cells(r, 14)).Value = "Brazil" Then

        Range(Cells(r, 1), Cells(r, LC)).Copy Destination:=Sheets("BR").Cells(dict("BR") + 1, 1)
        dict("BR") = Sheets("BR").Cells(Rows.Count, "B").End(xlUp).Row
        GoTo Nxt
    End If
 ''''  9 other IF statements structured the same way

Nxt:

Next r

Answer 1

这是一种不同的方法。它使用映射对象将工作表名称和行号存储在字典中。

Option Explicit

Sub CATsplit()

    Dim dict As New Scripting.Dictionary
    Dim LC As Long, LR As Long, r As Long, k
    Dim v

    dict.Add "NA", GetTerritory("No result", 2)
    dict.Add "AU", GetTerritory("Australia", 2)
    dict.Add "BR", GetTerritory("Brazil", 2)
    '...etc

    With ThisWorkbook
        For Each k In dict.keys
            .Sheets.Add(after:=.Sheets(.Sheets.Count)).Name = dict(k).sheetName
        Next k
    End With

    With Sheets(1)

        LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row

        For r = 2 To LR

            v = .Cells(r, 14).Value
            If Application.IsNA(.Cells(r, 11)) Then v = "NA"

            If dict.Exists(v) Then 'have a sheet for this row?
                .Cells(r, 1).Resize(1, LC).Copy _
                  ThisWorkbook.Sheets(dict(v).sheetName).Cells(dict(v).rowNum, 1)
                dict(v).rowNum = dict(v).rowNum + 1
            End If

        Next r
    End With

End Sub

“工厂”功能：

Function GetTerritory(sheetName As String, rowNum As Long) As Territory
    Dim rv As New Territory
    rv.sheetName = sheetName
    rv.rowNum = rowNum
    Set GetTerritory = rv
End Function

类模块“领土”：

Public sheetName As String
Public rowNum As Long

为清楚起见，我省略了禁用屏幕更新/计算的代码，但您可能应该添加它。

Answer 2

如果您打算冒险使用字典，我建议您考虑双脚并构建包含字典的字典。我相信您应该会看到这种技术的性能大大提高。

诚然，这项技术很长。每当出现新值时（在这种情况下将是一个新国家/地区），都可以创建动态生成的多级字典，但是，这需要构建一个超出此处要求的类模块。

Sub CATsplit()
Dim dnyRegion As New Scripting.Dictionary
Dim dnyOutput As New Scripting.Dictionary

Dim dnyAU As New Scripting.Dictionary
dnyRegion("Australia") = "AU"
dnyOutput.Add "AU", dnyAU

Dim dnyBR As New Scripting.Dictionary
dnyRegion("Brazil") = "BR"
dnyOutput.Add "BR", dnyBR

Dim dnyCAen As New Scripting.Dictionary
dnyRegion("Canada-English") = "CAen"
dnyOutput.Add "CAen", dnyCAen

Dim dnyCAfr As New Scripting.Dictionary
dnyRegion("Canada-French") = "CAfr"
dnyOutput.Add "CAfr", dnyCAfr

Dim dnyDE As New Scripting.Dictionary
dnyRegion("Denmark") = "DE"
dnyOutput.Add "DE", dnyDE

Dim dnyES As New Scripting.Dictionary
dnyRegion("Estonia") = "ES"
dnyOutput.Add "ES", dnyES

Dim dnyFR As New Scripting.Dictionary
dnyRegion("France") = "FR"
dnyOutput.Add "FR", dnyFR

Dim dnyIT As New Scripting.Dictionary
dnyRegion("Italy") = "IT"
dnyOutput.Add "IT", dnyIT

Dim dnyMX As New Scripting.Dictionary
dnyRegion("Mexico") = "MX"
dnyOutput.Add "MX", dnyMX

Dim dnyUK As New Scripting.Dictionary
dnyRegion("United Kingdom") = "UK"
dnyOutput.Add "UK", dnyUK

Dim dnyUSA As New Scripting.Dictionary
dnyRegion("United States") = "USA"
dnyOutput.Add "USA", dnyUSA

Dim dnyNA As New Scripting.Dictionary
'This will pick up everything else
dnyOutput.Add "NA", dnyNA

'This section sorts all of the data into the appropriate sub-dictionary.
Dim arrRow As Variant, strRegion As String, i0 As Long
With ActiveSheet
    For i0 = 1 To .UsedRange.Rows.Count
        strRegion = .Cells(i0, 14).Value
        If dnyRegion.Exists(strRegion) Then
            strRegion = dnyRegion(strRegion)
        Else
            strRegion = "NA"
        End If

        arrRow = .Range(.Cells(i0, 1), .Cells(i0, .UsedRange.Columns.Count)).Value
        dnyOutput(strRegion).Add dnyOutput(strRegion).Count + 1, arrRow
    Next i0
End With

'This section creates the appropriate tabs and dumps the data.
Dim eaRegion As Variant, eaRow As Variant, Dest As Range
For Each eaRegion In dnyOutput.Keys
    If dnyOutput(eaRegion).Count > 0 Then
        ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
        With ActiveWorkbook.Worksheets(Worksheets.Count)
            .Name = eaRegion
            For i0 = 1 To dnyOutput(eaRegion).Count
                Set Dest = .Cells(i0, 1)
                Dest.Resize(1, UBound(dnyOutput(eaRegion)(i0), 2)).Value = dnyOutput(eaRegion)(i0)
            Next i0
        End With
    End If
Next eaRegion
End Sub