按街道名称排列的 VBA 组属性
Posted
技术标签:
【中文标题】按街道名称排列的 VBA 组属性【英文标题】：VBA Group Properties by Street Name 【发布时间】：2017-06-20 23:40:36 【问题描述】：我有一段代码在一个范围内循环，并检查上面的单元格是否与当前单元格匹配。
当它找到当前上方的不同单元格时，插入一行，并将街道名称添加到“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
【问题讨论】：
排序呢？ 写入一个数组，在那里进行操作，然后写回工作表？ @R3uK，信息已经在此之前进行了排序，因此它的顺序正确。谢谢 你有没有把Application.ScreenUpdating = False加到sub的开头（一定要在结尾加Application.ScreenUpdating = True）？这将阻止您的工作表实时更新并使其运行得更快。
@SnWhte，是的，我在运行之前禁用了屏幕更新。谢谢
【参考方案1】：
只是一个想法，但您有很多变量定义为变体类型：
例如，在声明行中有：
将 lastRowWIR、lastRowPH、lastRowCODES、lastRow、lastCol As Long 调暗
这里只有 lastCol 被定义为 Long，其余都是变体类型，这是 VBA 的怪癖。
在可能的情况下将所有类型重新定义为集合类型可能有助于加快处理速度。
【讨论】：
以上是关于按街道名称排列的 VBA 组属性的主要内容，如果未能解决你的问题，请参考以下文章
CAD做一个LISP程序，实现按属性块图框里的一个图号按从左到右排列？