我正在尝试通过25,000多个订单项加快VBA中的循环
我有一些代码正在逐步遍历包含25,000多行的电子表格。现在，代码循环以为每个单元格都可以查看以前的单元格值是否与当前单元格值匹配。如果它们不匹配，则会插入新的空白行。现在，在相当快的计算机上完成代码需要5个小时以上的时间。有什么办法可以加快速度吗？
With ActiveSheet
BottomRow4 = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
Do
Cells(ActiveCell.Row, 5).Select
Do
ActiveCell.Offset(1, 0).Select
'Determines if previous cells is the same as current cells
Loop Until (ActiveCell.Offset(0, -1) & ActiveCell <>
ActiveCell.Offset(1, -1) & ActiveCell.Offset(1, 0))
'Insert Blank Row if previous cells do not match current cells...
Rows(ActiveCell.Offset(1, 0).Row & ":" & ActiveCell.Offset(1,
0).Row).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
BottomRow4 = BottomRow4 + 1
Loop Until ActiveCell.Row >= BottomRow4
答案 0 :(得分：2)
类似于删除行时，您可以保存插入内容，直到完成循环。
在要插入的列顶部（但不在第1行）上选择一个单元格后运行：
Sub Tester()
Dim c As Range, rngIns As Range, sht As Worksheet
Dim offSet As Long, cInsert As Range
Set sht = ActiveSheet
For Each c In sht.Range(Selection, _
sht.Cells(sht.Rows.Count, Selection.Column).End(xlUp)).Cells
offSet = IIf(offSet = 0, 1, 0) '<< toggle offset
If c.offSet(-1, 0).Value <> c.Value Then
'This is a workaround to prevent two adjacent cells from merging in
' the rngInsert range being built up...
Set cInsert = c.offSet(0, offSet)
If rngIns Is Nothing Then
Set rngIns = cInsert
Else
Set rngIns = Application.Union(cInsert, rngIns)
End If
End If
Next c
If Not rngIns Is Nothing Then
rngIns.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End Sub
编辑：使用="Val_" & ROUND(RAND()*1000)填充25k行，在3秒内运行，转换为值，然后排序。
答案 1 :(得分：1)
Sub InsertIfNotEqual()
Const cSheet As Variant = 1 ' Worksheet Name/Index
Const cFirstR As Long = 5 ' First Row
Const cCol As Variant = "E" ' Last-Row-Column Letter/Number
Dim rng As Range ' Last Cell Range, Union Range
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Source Array Row Counter
Dim j As Long ' Target Array Row Counter
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Determine the last used cell in Last-Row-Column.
Set rng = .Columns(cCol).Find("*", , xlFormulas, , , xlPrevious)
' Copy Column Range to Source Array.
vntS = .Cells(cFirstR, cCol).Resize(rng.Row - cFirstR + 1)
End With
' In Arrays
' Resize 1D Target Array to the first dimension of 2D Source Array.
ReDim vntT(1 To UBound(vntS)) As Long
' Loop through rows of Source Array.
For i = 2 To UBound(vntS)
' Check if current value is equal to previous value.
If vntS(i, 1) <> vntS(i - 1, 1) Then
' Increase row of Target Array.
j = j + 1
' Write Source Range Next Row Number to Target Array.
vntT(j) = i + cFirstR
End If
Next
' If no non-equal data was found.
If j = 0 Then Exit Sub
' Resize Target Array to found "non-equal data count".
ReDim Preserve vntT(1 To j) As Long
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Set Union range to first cell of row in Target Array.
Set rng = .Cells(vntT(1), 2)
' Check if there are more rows in Target Array.
If UBound(vntT) > 1 Then
' Loop through the rest of the rows (other than 1) in Target Array.
For i = 2 To UBound(vntT)
' Add corresponding cells to Union Range. To prevent the
' creation of "consecutive" ranges by Union, the resulting
' cells to be added are alternating between column A and B
' (1 and 2) using the Mod operator against the Target Array
' Row Counter divided by 2.
Set rng = Union(rng, .Cells(vntT(i), 1 + i Mod 2))
Next
End If
' Insert blank rows in one go.
rng.EntireRow.Insert
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
答案 2 :(得分：0)
编辑：添加了两个选项：未测试速度。我以为test2（）会更快，但不确定行数。
未经测试，但这只是我很快想到的。如果我记得的话，我会稍后再讲，因为我认为有更快的方法
Sub Test1()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then collectRows.Add rowNext
Next rowNext
For rowNext = 1 To collectRows.Count
wsSheet.Cells(collectRows(rowNext), 1).EntireRow.Insert
Next rowNext
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
第二个选项一次插入： 我在这里使用了一个字符串，因为union会将彼此相邻的行更改为一个更大的范围。它会创建（“ 1：2”）而不是Range（“ 1：1”，“ 2：2”），并且不会插入您需要的方式。我不知道更干净的方法，但是可能有。
Sub Test2()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Dim strRange As String
Dim cntRanges As Integer
Dim rngAdd As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then
strRange = wsSheet.Cells(rowNext, 1).EntireRow.Address & "," & strRange
cntRanges = cntRanges + 1
If cntRanges > 10 Then
collectRows.Add Left(strRange, Len(strRange) - 1)
strRange = vbNullString
cntRanges = 0
End If
End If
Next rowNext
If collectRows.Count > 0 Then
Dim i As Long
For i = 1 To collectRows.Count
Set rngAdd = Range(collectRows(i))
rngAdd.Insert
Next i
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub