按街道名称排列的 VBA 组属性

Question

我有一段代码在一个范围内循环，并检查上面的单元格是否与当前单元格匹配。

当它找到当前上方的不同单元格时，插入一行，并将街道名称添加到“A”列，然后继续。

我遇到的问题是它需要一段时间才能处理，你能建议一种不同的方法吗？

这是我目前正在使用的代码。

headingRange = wb.SCAA.cells(Rows.count, lastCol + 2).End(xlUp).Row
For headingID = headingRange To 7 Step -1
    lookupval = wb.SCAA.cells(headingID, lastCol + 2)
    With cells(headingID, lastCol + 2)
        If lookupval <> .Offset(-1) Then
            .EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
            With cells(headingID, 1)
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlCenter
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .Font.bold = True
                .Font.Underline = xlUnderlineStyleSingle
                .IndentLevel = 0
            End With
        cells(headingID, 1) = wb.SCAA.cells(headingID + 1, lastCol + 2)
        End If
    End With
Next headingID

这是我正在尝试处理的数据的示例屏幕截图。



这就是分组后数据的外观。



根据要求，这是整个潜艇。

Dim wb As Workbook: Set wb = ThisWorkbook
Dim lastRowWIR, lastRowPH, lastRowCODES, lastRow, lastCol As Long
Dim address, worktypeHeading, worktype_Valuation, headingID, headingRange, i As Long
Dim add_range_PH As Range, wID_range_PH As Range, sum_range_PH, sub_range_PH As Range
Dim add_range As Range, wID_range As Range, sum_range, sub_range As Range
Dim RangeCodes, RangeWIR, RangePH
Dim contract_total As Integer
Dim myRange As Range
Dim accountCode As Object: Set accountCode = CreateObject("Scripting.Dictionary")
Dim CodeList As Object: Set CodeList = CreateObject("Scripting.Dictionary")
Dim addressList As Object: Set addressList = CreateObject("Scripting.Dictionary")
Dim addressAFA As Object: Set addressAFA = CreateObject("Scripting.Dictionary")
Dim addressValuation As Object: Set addressValuation = CreateObject("Scripting.Dictionary")
Dim addressValuationTotal As Object: Set addressValuationTotal = CreateObject("Scripting.Dictionary")
Dim ContractList As Object: Set ContractList = CreateObject("Scripting.Dictionary")
Dim PHElementTotal As Object: Set PHElementTotal = CreateObject("Scripting.Dictionary")

'''' TEST IF THE WORKS INSTRUCTION RECORD AND PAYMENT HISTORY HAVE FILTERS APPLIED, IF TRUE THEN REMOVE THEM
If wb.WIR.FilterMode = True Then wb.WIR.AutoFilter.ShowAllData
If wb.PH.FilterMode = True Then wb.PH.AutoFilter.ShowAllData

'''' CALL THE PROGRESS USERFORM SUBROUTINE
Call UserFrmProgressSub("Currently Producing Statement for: " & wb.SCAA.cells(2, 2).value, False)

'''' DO THE FIRST DEFINE FOR LAST ROWS IN DIFFERENT SHEETS, AND LAST COLUMN
lastCol = wb.SCAA.cells(6, columns.count).End(xlToLeft).Column
lastRowWIR = wb.WIR.cells(Rows.count, WIR_AccountWorktypeID).End(xlUp).Row
lastRowPH = wb.PH.cells(Rows.count, "C").End(xlUp).Row
lastRowCODES = wb.CODES.cells(Rows.count, "F").End(xlUp).Row

'''' SET THE RANGE FOR THE EMAILIST DICTIOANARY CREATION
RangePH = wb.PH.Range("C2:H" & lastRowPH).value
RangeCodes = wb.CODES.Range("F3:G" & lastRowCODES).value
RangeWIR = wb.WIR.Range(wb.WIR.cells(3, WIR_AddressCode), wb.WIR.cells(lastRowWIR, WIR_ULRecharge)).value

'''' CREATE A SCRIPTING DICTIONARY TO HOLD THE ACCOUNT CODES (KEY:C, VALUE:CYCLICAL)
For i = LBound(RangeCodes) To UBound(RangeCodes, 1)
    '''' IF THE SUBCONTRACTOR IS NOT IN THE DICTIONARY THEN ADD IT
    If Not accountCode.exists(RangeCodes(i, 1)) Then accountCode.add RangeCodes(i, 1), RangeCodes(i, 2)
Next i

'''' CRAEATE MULTIPLE DICTIONARYS FROM THE WORKS INSTRUCTION RECORD
For i = LBound(RangeWIR) To UBound(RangeWIR, WIR_AddressCode)
    '''' ONLY ADD ITEMS TO THE RELEVANT DICTONARY IF THE SUBCONTRACTOR MATCHES THE SELECTED
    If RangeWIR(i, WIR_SubContractor) = cells(2, 2) Then
        '''' PRODUCE A CODE LIST FROM THE WIR BASED ON THE ACCOUNT WORKTYPE ID, THEN GET THE MATCHING VALUE FROM THE ACCONTCODE LIST KEYS FROM WIR, VALUE FROM CODELIST(KEY:L, VALUE:LIFECYLCE)
        If Not CodeList.exists(RangeWIR(i, WIR_AccountWorktypeID)) Then CodeList.add RangeWIR(i, WIR_AccountWorktypeID), accountCode(RangeWIR(i, WIR_AccountWorktypeID))
        '''' CREATE AND ADDRESS LIST WITH THE ADDRESS AS THE KEY, CONTACT, STREET AND PROPERTY NUMBER MAKE UP THE VALUE
        If Not addressList.exists(RangeWIR(i, WIR_AddressCode)) Then addressList.add RangeWIR(i, WIR_AddressCode), RangeWIR(i, WIR_Contract) & "|" & RangeWIR(i, WIR_Street) & "|" & Left(RangeWIR(i, WIR_AddressCode), InStr(RangeWIR(i, WIR_AddressCode), " "))
        '''' CREATE A DICTIONARY FOR THE CONTRACTS, EITHER PFI1, PFI2 OR BOTH
        If Not ContractList.exists(RangeWIR(i, WIR_Contract)) Then ContractList.add RangeWIR(i, WIR_Contract), RangeWIR(i, WIR_Contract)
        '''' DEFINE THE KEYS USED FOR THE ADDRESSAFA DICTONARY ADDRESS AND ACCOUNTWORKTYPE (14 ALMORAH ROAD|CYCLICAL)
        key = RangeWIR(i, WIR_AddressCode) & "|" & CodeList(RangeWIR(i, WIR_AccountWorktypeID))
        '''' THE ADDRESSAFA IS THE KEY AND THE RML ORDER VALUE FOR THAT ADDRESS AND CODE
        If Not addressAFA.exists(key) Then '''' IF THAT KEY IS NOT ALREADY IN THE DICTIONARY THE ADD IT WITH THE VALE
            addressAFA.add key, Round(RangeWIR(i, WIR_RMLOrderValue), 2)
        Else    '''' IF THE KEY IS IN THE DICTIONATY THE ADD THE NEW VALUE WITH WHATS ALREADY IN THE DICTIONARY
            addressAFA(key) = addressAFA(key) + Round(RangeWIR(i, WIR_RMLOrderValue), 2)
        End If
    End If
Next i

'''' CRAEATE MULTIPLE DICTIONARYS FROM THE PAYMENT HISTORY
For i = LBound(RangePH) To UBound(RangePH, 1)
    If RangePH(i, 2) = cells(2, 2) Then
        key = RangePH(i, 1) & "|" & CodeList(RangePH(i, 3))
        '''' TOTAL VALUE FOR ADDRESS & ELEMTENT (CYCLICAL)
        If Not addressValuation.exists(key) Then
            addressValuation.add key, Round(RangePH(i, 6), 2)
        Else
            addressValuation(key) = addressValuation(key) + Round(RangePH(i, 6), 2)
        End If
        '''' TOTAL VALUE FOR ADDRESS
        If Not addressValuationTotal.exists(RangePH(i, 1)) Then
            addressValuationTotal.add RangePH(i, 1), Round(RangePH(i, 6), 2)
        Else
            addressValuationTotal(RangePH(i, 1)) = addressValuationTotal(RangePH(i, 1)) + Round(RangePH(i, 6), 2)
        End If
        '''' PRODUCE A CODE LIST FROM THE WIR BASED ON THE ACCOUNT WORKTYPE ID, THEN GET THE MATCHING VALUE FROM THE ACCONTCODE LIST KEYS FROM WIR, VALUE FROM CODELIST(KEY:L, VALUE:LIFECYLCE)
        If Not PHElementTotal.exists(accountCode(RangePH(i, 3))) Then
            PHElementTotal.add accountCode(RangePH(i, 3)), Round(RangePH(i, 6), 2)
        Else
            PHElementTotal(accountCode(RangePH(i, 3))) = PHElementTotal(accountCode(RangePH(i, 3))) + Round(RangePH(i, 6), 2)
        End If
        If Not PHElementTotal.exists("Total") Then
            PHElementTotal.add "Total", Round(RangePH(i, 6), 2)
        Else
            PHElementTotal("Total") = PHElementTotal("Total") + Round(RangePH(i, 6), 2)
        End If
    End If
Next i

'''' SET THE ACCOUNTCODE DICTIONATY TO NOTHING TO FREE MEMORY (NOT USED AGAIN IN ROUTINE)
Set accountCode = Nothing

'''' TEST IF THE CODELIST HAS A COUNT OF 0, IF TRUE THE SUBCONTRACTO HAD NO WORK ISSUED TO THEN AND NOTHING PAID TO THEN. EXIT THE SUB
If CodeList.count = "0" Then
    MsgBox wb.SCAA.cells(2, 2).value & " has had no works issued to them." & vbLf & "A statement cannot be produced!", vbCritical, "SubContractor Statement Error"
    Exit Sub
End If

'''' CLEAR THE SHEET BEFORE STARTING
wb.SCAA.Rows("4:" & wb.SCAA.cells(Rows.count, lastCol).End(xlUp).Row + 10).Clear

'''' CALL THE SUBROUTINE TO CREATE THE SHEET HEADINGS
Call createSCAccountHeadings1(CodeList.count, CodeList)

'''' REDEFINE THE LAST COLUMN AFTER THE HEADINGS HAVE BEEN CREATED
lastCol = wb.SCAA.cells(6, columns.count).End(xlToLeft).Column

'''' LOOP OVER THE ADDRESS LIST, AND SPLIT THE ITEM, TO ADD THE ADDRESS, PFI, PROPERTY NUMBER AND STREET TO SHEET
tableStart = 7
For Each key In addressList.keys
    wb.SCAA.cells(tableStart, 1) = key
    wb.SCAA.cells(tableStart, 2) = Split(addressList(key), "|")(0)
    wb.SCAA.cells(tableStart, lastCol + 2) = Split(addressList(key), "|")(1)
    wb.SCAA.cells(tableStart, lastCol + 1) = Split(addressList(key), "|")(2)
    tableStart = tableStart + 1
Next key

'''' DEFINE THE LASTROW
lastRow = wb.SCAA.cells(Rows.count, 1).End(xlUp).Row

'''' APPLY INDENTS TO THE ADDRESS'S AND AUTOFIT COLUMN 1
wb.SCAA.Range("A7:A" & lastRow).InsertIndent 2
wb.SCAA.columns(1).AutoFit

'''' SET THE RANGES IN FOR THE SUM IF FUNCTIONS USED.
Set add_range = wb.WIR.columns(WIR_AddressCode)
Set wID_range = wb.WIR.columns(WIR_AccountWorktypeID)
Set sub_range = wb.WIR.columns(WIR_SubContractor)
Set sum_range = wb.WIR.columns(WIR_RMLOrderValue)
Set add_range_PH = wb.PH.Range("C:C")
Set wID_range_PH = wb.PH.Range("E:E")
Set sub_range_PH = wb.PH.Range("D:D")
Set sum_range_PH = wb.PH.Range("H:H")

'''' DEFINE MYRANGE
Set myRange = Range(cells(3, 1), cells(lastRow, lastCol))

'''' LOOP OVER THE ADDRESS AND WORKTYPE(COLUMNS), AND ADD VALUES AND FORMULAS
For address = 7 To lastRow
addressIns = wb.SCAA.cells(address, 1).value
    For worktypeHeading = 3 To myRange.columns.count
    Set wtHeading = wb.SCAA.cells(6, worktypeHeading)
        Select Case True
            Case worktypeHeading - 2 <= CodeList.count
                If IsEmpty(addressAFA(addressIns & "|" & wtHeading)) Then
                    wb.SCAA.cells(address, worktypeHeading) = 0
                Else
                    wb.SCAA.cells(address, worktypeHeading) = Format(addressAFA(addressIns & "|" & wtHeading), "Standard")
                End If
                wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
            Case worktypeHeading - 2 = CodeList.count + 1
                wb.SCAA.cells(address, worktypeHeading).value = Round(Application.WorksheetFunction.Sum(Range(cells(address, 3), cells(address, worktypeHeading - 1))), 2)
                wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
            Case worktypeHeading - 2 = CodeList.count + 2
                If cells(address, worktypeHeading - 1) = "0" And (addressValuationTotal(addressIns) = "0" Or IsEmpty(addressValuationTotal(addressIns))) Then
                    wb.SCAA.cells(address, worktypeHeading).value = "0"
                Else
                    wb.SCAA.cells(address, worktypeHeading).value = addressValuationTotal(addressIns) / cells(address, worktypeHeading - 1)
                End If
                wb.SCAA.cells(address, worktypeHeading).NumberFormat = "0.00%"
                wb.SCAA.cells(address, "AAA").value = wb.SCAA.cells(address, worktypeHeading)
                wb.SCAA.columns(worktypeHeading).AutoFit
            Case worktypeHeading - 2 > CodeList.count And worktypeHeading - 2 < myRange.columns.count - 2
                If IsEmpty(addressValuation(addressIns & "|" & wtHeading)) Then
                    totalValuation = 0
                Else
                    totalValuation = addressValuation(addressIns & "|" & wtHeading)
                End If
                myformula = "=Round(IF(" & cells(address, (worktypeHeading - (CodeList.count + 2))).address(False, False) & "=" & totalValuation & "," & totalValuation & "," & "SUM(" & cells(address, (worktypeHeading - (CodeList.count + 2))).address(False, False) & "*" & cells(address, CodeList.count + 4).address(False, False) & ")),2)"
                wb.SCAA.cells(address, worktypeHeading).formula = myformula
                wb.SCAA.cells(address, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
            Case worktypeHeading - 2 = myRange.columns.count - 2
                wb.SCAA.cells(address, lastCol).formula = "=round(sum(" & cells(address, 5 + CodeList.count).address(False, False) & ":" & cells(address, worktypeHeading - 1).address(False, False) & "),2)"
                wb.SCAA.cells(address, lastCol).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
        End Select
    Next worktypeHeading
Next address

'''' SET THE BELOW SCRIPTING DICTIONARYS TO NOTHING, TO FREE MEMORY
Set addressList = Nothing
Set addressAFA = Nothing
Set addressValuation = Nothing
Set addressValuationTotal = Nothing

'''' REDEFINE THE LAST ROW
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row

'''' TRANSPOSE THE CONTRACT LIST ON TO THE SHEET UNDER THE ADDRESS
wb.SCAA.Range("B" & lastRow + 2).Resize(ContractList.count, 1) = WorksheetFunction.Transpose(ContractList.keys)

'''' SORT THE CONTRACT LIST A - Z
If ContractList.count <> 1 Then wb.SCAA.Range("B" & lastRow + 2 & ":B" & lastRow + 2 + (ContractList.count - 1)).Sort Key1:=cells(lastRow + 2, 2), Order1:=xlAscending, Header:=xlNo

'''' DEFINE THE LAST ROW IN COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row

'''' ADD "TOTAL" TO THE SHEET
wb.SCAA.cells(lastRowB + 2, 2) = "TOTAL"

'''' LOOP OVER THE CONTRACT LIST AT BOTTOM AND TOTAL, AND ADD FORMULAS THERE APPRIOPRIATE
For contract_total = lastRow + 2 To lastRowB + 2
    For worktypeHeading = 3 To myRange.columns.count
    Set wtHeading = wb.SCAA.cells(6, worktypeHeading)
    If contract_total = lastRowB + 1 Then Exit For
    If wtHeading.Offset(-1) <> "PROGRESS" Then
        If contract_total <> lastRowB + 2 Then
            wb.SCAA.cells(contract_total, worktypeHeading).formula = "=round(sumif(" & cells(7, 2).address & ":" & cells(lastRow, 2).address & "," & cells(contract_total, 2).address & "," & cells(7, worktypeHeading).address & ":" & cells(lastRow, worktypeHeading).address & "),2)"
            wb.SCAA.cells(contract_total, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
        Else
            wb.SCAA.cells(lastRowB + 2, worktypeHeading).formula = "=round(Sum(" & cells(lastRowB - 1, worktypeHeading).address & ":" & cells(lastRowB, worktypeHeading).address & "),2)"
            wb.SCAA.cells(lastRowB + 2, worktypeHeading).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
        End If
    End If
    Next worktypeHeading
Next contract_total

'''' RE-DEFINE THE LAST ROW IN COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row

'''' ADD TWO HEADINGS
wb.SCAA.cells(lastRowB + 2, 3 + CodeList.count) = "TOTAL ALREADY PAID"
wb.SCAA.cells(lastRowB + 4, 3 + CodeList.count) = "TOTAL CHANGED"

'''' ADD THE FORMULAS TO THE TOTAL ALDREAY PAID, AND TOTAL CHANGED
For worktype_Valuation = CodeList.count + 5 To myRange.columns.count
    worktype_value = wb.SCAA.cells(6, worktype_Valuation)
    If IsEmpty(PHElementTotal(worktype_value)) Or PHElementTotal(worktype_value) = 0 Then
        tempTotal = 0
    Else
        tempTotal = PHElementTotal(worktype_value)
    End If
    If worktype_value <> "Total" Then
        wb.SCAA.cells(lastRowB + 2, worktype_Valuation) = tempTotal
        wb.SCAA.cells(lastRowB + 2, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
        wb.SCAA.cells(lastRowB + 4, worktype_Valuation).formula = "=round(sum(" & cells(lastRowB, worktype_Valuation).address & ":" & cells(lastRowB, worktype_Valuation).address & ",-" & cells(lastRowB + 2, worktype_Valuation).address & "),2)"
        wb.SCAA.cells(lastRowB + 4, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
    Else
        wb.SCAA.cells(lastRowB + 2, worktype_Valuation) = tempTotal
        wb.SCAA.cells(lastRowB + 2, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
        wb.SCAA.cells(lastRowB + 4, worktype_Valuation).formula = "=round(sum(" & cells(lastRowB, worktype_Valuation).address & ":" & cells(lastRowB, worktype_Valuation).address & ",-" & cells(lastRowB + 2, worktype_Valuation).address & "),2)"
        wb.SCAA.cells(lastRowB + 4, worktype_Valuation).NumberFormat = "#,##0.00_ ;[Red](#,##0.00)"
    End If
Next worktype_Valuation

Set PHElementTotal = Nothing

'''' CALL THE SORTING SUB ROUTINE
Call sortData(wb.SCAA, 7, (lastRow), (lastCol + 2), False, (lastCol + 1))

'''' LOOP OVER THE ROWS, AND SEPERATE THE ADDRESS INTO SREETS
headingRange = wb.SCAA.cells(Rows.count, lastCol + 2).End(xlUp).Row
For headingID = headingRange To 7 Step -1
    lookupval = wb.SCAA.cells(headingID, lastCol + 2)
    With cells(headingID, lastCol + 2)
        If lookupval <> .Offset(-1) Then
            .EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow
            With cells(headingID, 1)
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlCenter
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .Font.bold = True
                .Font.Underline = xlUnderlineStyleSingle
                .IndentLevel = 0
            End With
        cells(headingID, 1) = wb.SCAA.cells(headingID + 1, lastCol + 2)
        End If
    End With
Next headingID

'''' ONCE ADDRESS'S HAVE BEEN SORTED AND ADDRESS'S GROUPED INTO STREETS, CLEAR THE STREET HAS PROPERTY NUMBER IN THE LAST 2 COLUMNS
With Union(columns(lastCol + 1), columns(lastCol + 2))
    .ClearContents
End With

'''' REFINE LAST ROW: COLUMN A, AND LAST ROW B: COLUMN B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row

'''' APPLY BORDERS TO THE SHEET, AND FORMAT
With wb.SCAA
    With Union(Range(cells(7, 1), cells(lastRow, lastCol)), _
               Range(cells(lastRowB, 2), cells(lastRowB, CodeList.count + 3)), _
               Range(cells(lastRowB, 5 + CodeList.count), cells(lastRowB, lastCol)), _
               Range(cells(lastRow + 2, 2), cells(lastRow + 1 + ContractList.count, 2 + CodeList.count + 1)), _
               Range(cells(lastRow + 2, 5 + CodeList.count), cells(lastRow + 1 + ContractList.count, lastCol)), _
               Range(cells(lastRowB + 2, 5 + CodeList.count), cells(lastRowB + 2, lastCol)), _
               Range(cells(lastRowB + 4, 5 + CodeList.count), cells(lastRowB + 4, lastCol)))
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThick
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlThin
            With Range(cells(7, 2), cells(lastRowB, 2))
                .HorizontalAlignment = xlVAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With Union(Range(cells(7, 1), cells(lastRow, 1)), _
                       Range(cells(7, 2), cells(lastRow, 2)), _
                       Range(cells(7, 4 + CodeList.count), cells(lastRow, 4 + CodeList.count)))
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeLeft).Weight = xlThick
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeRight).Weight = xlThick
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideVertical).Weight = xlThick
            End With
    End With
End With

'''' LOOP OVER ALL THE ADDRESS'S AND APPLY CONDITIONAL FORMATTING
lastRow = wb.SCAA.cells(Rows.count, "A").End(xlUp).Row
For address = 7 To lastRow
    If IsEmpty(cells(address, 4 + CodeList.count).value) = False Then
        With wb.SCAA.Range(wb.SCAA.cells(address, 1), wb.SCAA.cells(address, lastCol))
            .FormatConditions.add Type:=xlExpression, Formula1:="=" & cells(address, 4 + CodeList.count).address(False) & ">1"
            .FormatConditions(1).Interior.Color = RGB(215, 150, 148)
            .FormatConditions(1).StopIfTrue = False
            .FormatConditions.add Type:=xlExpression, Formula1:="=" & cells(address, 4 + CodeList.count).address(False) & "<>" & wb.SCAA.cells(address, "AAA").address(False) & ""
            .FormatConditions(2).Interior.Color = RGB(196, 215, 155)
            .FormatConditions(2).StopIfTrue = False
        End With
    End If
Next address

wb.SCAA.Range(columns(2), columns(lastCol)).ColumnWidth = 14

'''' RE-DEFINE THE LAST ROW B
lastRowB = wb.SCAA.cells(Rows.count, "B").End(xlUp).Row

'''' LOCK ALL THE CELLS IN SHEET
wb.SCAA.Range(wb.SCAA.cells(1, 1), wb.SCAA.cells(lastRowB + 4, lastCol)).Locked = True

'''' UNLOCK THE PROGRESS COLUMN TO BE ABLE TO CHANGE THE PERCENTAGES
wb.SCAA.Range(wb.SCAA.cells(7, 4 + CodeList.count), wb.SCAA.cells(wb.SCAA.cells(Rows.count, "A").End(xlUp).Row, 4 + CodeList.count)).Locked = False

'''' SET CONTRACT LIST AND CODE LIST TO NOTHING TO AVOID MEMORY LEAKS
Set ContractList = Nothing
Set CodeList = Nothing

Answer 1

只是一个想法，但您有很多变量定义为变体类型:

例如，在声明行中，您有:

暗淡 lastRowWIR、lastRowPH、lastRowCODES、lastRow、lastCol As Long

在这里，只有 lastCol 被定义为 Long，其余的都是变体类型，这是 VBA 的怪癖。

在可能的情况下将所有重新定义为集合类型可能有助于您的处理速度。