VBA 如何使嵌套循环更快

问题描述 投票：0回答：1

我创建了一个宏，它从一张工作表中获取原始数据，并将其转换为其他 19 张工作表中的 sumifs 公式。问题是每个列迭代大约需要 1 分钟才能完成。我该怎么做才能使代码的主要瓶颈更快？

'Units (Bottle Neck)
Dim B(), totalsum As Double, refnum As Integer, x As Integer
ReDim B(1 To 254, 1 To nr)
counter = 1
refnum = 1

For x = 39 To 51
    For snum = 1 To 19
        For refnum = 1 To 254
                For i = 3 To nr
                    If Left(A(i, 4), 5) = sorter(snum) And A(i, 5) = "2022" And A(i, 10) = Sheets(sorter(snum)).Cells(refnum + 5, 3) Then
                        B(refnum, counter) = A(i, x)
                        counter = counter + 1
                    End If
                Next i
                counter = 1
        Next refnum
            refnum = 1
            For refnum = 1 To UBound(B)
                For i = LBound(B) To UBound(B)
                    totalsum = totalsum + B(refnum, i)
                Next i
                Sheets(sorter(snum)).Cells(refnum + 5, x + 3) = totalsum
                totalsum = 0
            Next refnum
    Next snum
Next x
Erase B

Here is the script in entirety...

Option Explicit
Option Base 1

Sub CBKdump()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim A(), nr As Long, nc As Integer, i As Long, j As Integer, item As Variant
Dim Dictionary As Object, sheetName As String, ws As Worksheet, Dict As Object, counter As Integer
Dim starttime As Double, endtime As Double

'timer
starttime = Timer

Sheets("CBK200 Raw Data").Select
nr = WorksheetFunction.CountA(Range(Cells(2, 1), Cells(2, 1).End(xlDown))) + 1
nc = Range(Cells(2, 1), Cells(2, 1).End(xlToRight)).Columns.Count

'CBK Array A()
ReDim A(3 To nr, 1 To nc)

For i = 3 To nr
    For j = 1 To nc
        On Error Resume Next
        On Error GoTo 0
        If Not IsError(Cells(i, j)) Then
            A(i, j) = Application.WorksheetFunction.Trim(Cells(i, j))
        Else
            A(i, j) = ""
        End If
    Next j
Next i

'find sheet name
Set Dictionary = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(A)
    If Not IsEmpty(A(i, 4)) And Not Dictionary.Exists(A(i, 4)) Then
        Dictionary.Add A(i, 4), Nothing
    End If
Next i

'Dict to array
i = 1
For Each item In Dictionary
    Dim sorter(), s As Variant
    ReDim Preserve sorter(1 To Dictionary.Count)
    sorter(i) = Left(item, 5)
    i = i + 1
Next item

'reverse array & create pages
Dim sorted()
For i = UBound(sorter) To 1 Step -1
    ReDim Preserve sorted(1 To UBound(sorter))
    sorted(i) = sorter(i)
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = sorter(i)
Next i

'reorganize cbk and all orgs
Sheets("All Orgs").Move Before:=Sheets(5)
Sheets("CBK200 Raw Data").Move Before:=Sheets(5)

'===============Resource Unit=====================

'open itrack workbook
Dim wb As Workbook
Dim filePath As String
filePath = "C:\Users\E100676\Documents\Billy\Backup\iTrack_Resource.xlsx"
Set wb = Workbooks.Open(filePath)

'add itrack wb data to array
Workbooks("iTrack_Resource").Sheets(1).Select
Dim inr As Integer, t(), snum As Integer
inr = Range(Cells(2, 1), Cells(2, 1).End(xlDown)).Rows.Count
ReDim t(inr, 2)

For snum = 1 To UBound(sorter)
    For i = 2 To inr + 1
        For j = 1 To 2
            t(i - 1, j) = Trim(Cells(i, j))
        Next j
    Next i
Next snum

wb.Close SaveChanges:=False

'arrange by t array
Workbooks("Budget Test Sheet").Activate

For snum = 1 To UBound(sorter)
    For i = 6 To UBound(t)
        Sheets(sorter(snum)).Cells(i, 2) = t(i - 5, 1)
        Sheets(sorter(snum)).Cells(i, 3) = t(i - 5, 2)
        Sheets(sorter(snum)).Columns("P:AO").Hidden = True
    Next i
Next snum

'GL Account
For snum = 1 To UBound(sorter)
    For i = 6 To Sheets(sorter(snum)).Cells(6, 2).End(xlDown).Row
        If Sheets(sorter(snum)).Cells(i, 2) = 1 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52734
        ElseIf Sheets(sorter(snum)).Cells(i, 2) >= 2 And Sheets(sorter(snum)).Cells(i, 2) <= 26 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52725
        ElseIf Sheets(sorter(snum)).Cells(i, 2) >= 27 And Sheets(sorter(snum)).Cells(i, 2) <= 52 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52728
        ElseIf Sheets(sorter(snum)).Cells(i, 2) >= 53 And Sheets(sorter(snum)).Cells(i, 2) <= 89 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52732
        ElseIf Sheets(sorter(snum)).Cells(i, 2) >= 90 And Sheets(sorter(snum)).Cells(i, 2) <= 188 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52721
        ElseIf Sheets(sorter(snum)).Cells(i, 2) >= 189 And Sheets(sorter(snum)).Cells(i, 2) <= 245 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52723
        ElseIf Sheets(sorter(snum)).Cells(i, 2) >= 246 And Sheets(sorter(snum)).Cells(i, 2) <= 252 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52750
        ElseIf Sheets(sorter(snum)).Cells(i, 2) = 253 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52723
        ElseIf Sheets(sorter(snum)).Cells(i, 2) = 254 Then
            Sheets(sorter(snum)).Cells(i, 4) = 52752
        End If
    Next i
Next snum



'Headers
For snum = 1 To UBound(sorter)
    With Sheets(sorter(snum))
        .Cells(1, 1) = "Year - Division - Low Org"
        .Cells(1, 2) = "Ref"
        .Cells(1, 3) = "Resource Unit"
        .Cells(1, 4) = "GL Account"
        .Cells(1, 5) = "Unit of Measure"
        .Cells(1, 6) = "Pricing"
        .Cells(1, 7) = "Resource Unit Fee"
        .Cells(1, 8) = "Full Year % Allocation"
        .Cells(1, 9) = "Units"
        .Cells(1, 10) = "2023 Units"
        .Cells(1, 11) = "2023 Amount"
        .Cells(1, 12) = "2022 Projected Units"
        .Cells(1, 13) = "2022 Projected Amount"
        .Cells(1, 14) = "Use"
        .Cells(1, 15) = "Usage"
        .Cells(1, 16) = "Next FY Units"
        .Cells(1, 17) = "Jul Units"
        .Cells(1, 18) = "Aug Units"
        .Cells(1, 19) = "Sep Units"
        .Cells(1, 20) = "Oct Units"
        .Cells(1, 21) = "Nov Units"
        .Cells(1, 22) = "Dec Units"
        .Cells(1, 23) = "Jan Units"
        .Cells(1, 24) = "Feb Units"
        .Cells(1, 25) = "Mar Units"
        .Cells(1, 26) = "Apr Units"
        .Cells(1, 27) = "May Units"
        .Cells(1, 28) = "Jun Units"
        .Cells(1, 29) = "Next Fy $"
        .Cells(1, 30) = "Jul $"
        .Cells(1, 31) = "Aug $"
        .Cells(1, 32) = "Sep $"
        .Cells(1, 33) = "Oct $"
        .Cells(1, 34) = "Nov $"
        .Cells(1, 35) = "Dec $"
        .Cells(1, 36) = "Jan $"
        .Cells(1, 37) = "Feb $"
        .Cells(1, 38) = "Mar $"
        .Cells(1, 39) = "Apr $"
        .Cells(1, 40) = "May $"
        .Cells(1, 41) = "Jun $"
        .Cells(1, 42) = "Current Actuals YTD Units"
        .Cells(1, 43) = "Jul Units"
        .Cells(1, 44) = "Aug Units"
        .Cells(1, 45) = "Sep Units"
        .Cells(1, 46) = "Oct Units"
        .Cells(1, 47) = "Nov Units"
        .Cells(1, 48) = "Dec Units"
        .Cells(1, 49) = "Jan Units"
        .Cells(1, 50) = "Feb Units"
        .Cells(1, 51) = "Mar Units"
        .Cells(1, 52) = "Apr Units"
        .Cells(1, 53) = "May Units"
        .Cells(1, 54) = "Jun Units"
        .Cells(1, 55) = "Current Actuals YTD $"
        .Cells(1, 56) = "Jul $"
        .Cells(1, 57) = "Aug $"
        .Cells(1, 58) = "Sep $"
        .Cells(1, 59) = "Oct $"
        .Cells(1, 60) = "Nov $"
        .Cells(1, 61) = "Dec $"
        .Cells(1, 62) = "Jan $"
        .Cells(1, 63) = "Feb $"
        .Cells(1, 64) = "Mar $"
        .Cells(1, 65) = "Apr $"
        .Cells(1, 66) = "May $"
        .Cells(1, 67) = "Jun $"
        .Cells(1, 68) = "Current FY Budgeted Units"
        .Cells(1, 69) = "Current FY Budgeted $"
        .Cells(1, 70) = "Compare Units"
        .Cells(1, 71) = "Compare $"
    End With
    With Sheets(sorter(snum)).Range("A1:BS1")
        .Borders(xlEdgeBottom).Weight = xlThin
        .RowHeight = 45
    End With
    Sheets(sorter(snum)).Range("J1:M1").Interior.Color = RGB(226, 239, 218)
Next snum

'Units (Bottle Neck)
Dim B(), totalsum As Double, refnum As Integer, x As Integer
ReDim B(1 To 254, 1 To nr)
counter = 1
refnum = 1

For x = 39 To 51
    For snum = 1 To 19
        For refnum = 1 To 254
                For i = 3 To nr
                    If Left(A(i, 4), 5) = sorter(snum) And A(i, 5) = "2022" And A(i, 10) = Sheets(sorter(snum)).Cells(refnum + 5, 3) Then
                        B(refnum, counter) = A(i, x)
                        counter = counter + 1
                    End If
                Next i
                counter = 1
        Next refnum
            refnum = 1
            For refnum = 1 To UBound(B)
                For i = LBound(B) To UBound(B)
                    totalsum = totalsum + B(refnum, i)
                Next i
                Sheets(sorter(snum)).Cells(refnum + 5, x + 3) = totalsum
                totalsum = 0
            Next refnum
    Next snum
Next x
Erase B

'end time
endtime = Timer - starttime
Debug.Print endtime

'Amounts
ReDim B(1 To 254, 1 To nr)
counter = 1
refnum = 1

For x = 26 To 38
    For snum = 1 To 19
        For refnum = 1 To 254
                For i = 3 To nr
                    If Left(A(i, 4), 5) = sorter(snum) And A(i, 5) = "2022" And A(i, 10) = Sheets(sorter(snum)).Cells(refnum + 5, 3) Then
                            B(refnum, counter) = A(i, x)
                            counter = counter + 1
                    End If
                Next i
                counter = 1
        Next refnum
            refnum = 1
            For refnum = 1 To UBound(B)
                For i = LBound(B) To UBound(B)
                    totalsum = totalsum + B(refnum, i)
                Next i
                Sheets(sorter(snum)).Cells(refnum + 5, x + 29) = totalsum
                totalsum = 0
            Next refnum
    Next snum
Next x

'add years
For snum = 1 To 19
    Sheets(sorter(snum)).Cells(5, 1) = sorter(snum)
    Columns("AP:BB").NumberFormat = "0.00"
    Columns("BC:BS").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
Next snum




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

我尝试减少循环数量，但我发现我需要不同的计数器。 NR 约为 35,000 行。正如您在瓶颈处所看到的，它会遍历每个单元格并创建一个 sumifs 公式，但有 254 行、56 列和 19 个工作表，即创建了 270,256 个 sumifs 公式。请帮助 Stack Overflow，你是我唯一的希望。

excel vba loops lag
1个回答
0
投票

您的循环次数超出了您的需要。

想象一个类，您将在每张纸上创建一个实例（

snum
），该实例具有获取信息的方法，然后编写它。因此，每个实例都可以有自己的数组、计数器等，而不会互相干扰。

现在想象一下这些对象的字典。

现在想象一个函数，您可以在其中传递一个行范围，例如

Set sht = Sheets("CBK200 Raw Data")
Set FirstCell = Cells(2, 1)
Set LastCell = FirstCell.End(xlDown).End(xlToRight)
Set rng = sht.Range(FirstCell, LastCell)
For Each rw In rng.Rows
  Ingest DictionaryOfSheetControllers, rw
Next


Ingest
在哪里

Sub Ingest(DictionaryOfSheetControllers, rw as Range)
  Dim SheetNameCell as Range

  SheetNameCell = rw.Cells(1, 4)
  Set controller = GetSheetController(DictionaryOfSheetControllers, SheetNameCell)
  If Not controller Is Nothing Then
    controller.ImportRawRow(rw)
  End Of
End Sub

其中 

GetSheetController
要么从 
DictionaryOfSheetControllers
返回现有的 SheetController，创建一个新的 SheetController，将其添加到 
DictionaryOfSheetControllers
并返回它，或者如果不应将道路添加到任何图纸，则返回 
Nothing
。

通过这种方式，您将循环访问输入行一次。您根本没有创建 

A
数组，您没有修剪不需要修剪的值，您不需要循环遍历数据只是为了首先获取所有工作表名称，因为您正在创建新的动态工作表名称等

然后，导入所有玫瑰后，您可以循环遍历字典并调用方法来输出结果。

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.