VBA组属性按街道名称

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

当它find当前的不同单元格时，插入一行，并将街道名称添加到列“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

只是一个想法，但你有很多variables定义为变体types：

例如，在声明行中您有：

Dim lastRowWIR，lastRowPH，lastRowCODES，lastRow，lastCol As Long

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

在可能的情况下将所有types重新定义为所有types都可能有助于提高stream程速