加速VBA代码来查找具有相似数字的行
我有和excel充满了0和1这样的一个： 
我想find哪些行与其他行有三（1）个共同的行，并删除它们。
例如，检查行有三（1）共同第一行我把这个函数在列G：
G2： =SUM.IF(A2:F2;"=1";A2:F2)
G3： =SUM.IF(A2:F2;"=1";A3:F3)
G4： =SUM.IF(A2:F2;"=1";A4:F4)
G5： =SUM.IF(A2:F2;"=1";A5:F5)
显然我想这样做到很多行（5000 ++）和列（51），这是我的代码：
Sub Macro_NUEVA() Dim maxRows, maxColumns, rowCount, row As Integer maxRows= 10 maxColumns= 51 maxRows = InputBox("Number of rows?:", "Number of rows") sngStartTime = Timer 'Just a timer Application.ScreenUpdating = False 'Do not update screen to save some time For rowCount = 2 To maxRows 'Iterate all Rows For row = rowCount To maxRows 'loop to compare every single row with the actual row ActiveSheet.Cells(row, maxRows + 1).Select ActiveCell.Formula = "=SUMIF(" & Range("B" & rowCount & ":AY" & rowCount ).Address(False, False) & ",""=1""," & Range("B" & row & ":AY" & row).Address(False, False) & ")" If Selection = 3 Then 'If three ones in common -> delete row Selection.EntireRow.Delete maxRows = maxRows - 1 row= row- 1 End If Next row Next rowCount Application.ScreenUpdating = True sngTotalTime = Timer - sngStartTime MsgBox "Tiempo Empleado: " & Round(sngTotalTime, 2) & " Segundos" End Sub
此代码工作正常，但它需要很多时间…（7000行 – > 25小时）
我是一个VBA的初学者，我不知道这个代码是否有效，但我没有find任何其他方式来解决这个问题，我也想在C中做这个程序（只是parsing一个CSV ）。
看看这是否加快你的速度。 testingA2：AY5000填充=RANDBETWEEN(0,1)然后复制并粘贴特殊值。 第1行是带有列标签的标题行。 您将需要重命名您的工作表Matriz或修改命名工作表的代码行。
Option Explicit Sub Macro_NUEVA() Dim maxRws As Long, maxCols As Long, rwCount As Long, ws As Worksheet Dim f As Long, fc As Long, c As Long, cl As Long, rw As Long, n As Long Dim sngTime As Double, app As Application maxRws = 5000 maxRws = InputBox("Número de filas?:", "Número de filas", maxRws) Set app = Application app.ScreenUpdating = False app.EnableEvents = False app.Calculation = xlCalculationManual sngTime = Timer 'Just a timer Set ws = Sheets("Matriz") With ws.Cells(1, 1).CurrentRegion If Not ws.AutoFilterMode Then .AutoFilter On Error Resume Next: ws.ShowAllData: On Error GoTo 0 maxCols = .Columns.Count For rw = 2 To maxRws For cl = 1 To (.Columns.Count - 2) If app.CountIf(.Cells(rw, cl).Resize(1, (maxCols - cl) + 1), 1) > 2 Then f = 0 For fc = cl To maxCols If .Cells(rw, fc).Value = 1 Then .AutoFilter Field:=fc, Criteria1:=1 f = f + 1 If f = 3 Then Exit For End If Next fc If f = 3 And app.Subtotal(102, .Columns(1)) > 1 Then Debug.Print "deleting " & app.Subtotal(102, .Columns(1)) - 1 & " row(s)" '.Offset(2, 0).EntireRow.Delete Shift:=xlUp 'next line is a modification of the offset to delete .Offset(.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1).Row, 0).EntireRow.Delete Shift:=xlUp End If ws.ShowAllData End If Next cl If Not CBool(app.Count(Rows(rw + 1))) Then Exit For Next rw If ws.AutoFilterMode Then .AutoFilter End With Set ws = Nothing sngTime = Timer - sngTime MsgBox "Tiempo Empleado: " & Round(sngTime, 2) & " Segundos" app.Calculation = xlCalculationAutomatic app.EnableEvents = False app.ScreenUpdating = True Set app = Application End Sub
你自己的时间将大大取决于零和零的比例。 如果RANDBETWEEN正常运转，矿井是50％/ 50％。 更多的零意味着更多的行和列必须被检查。 您可以检查VBE的即时窗口中被删除的行数。
有一个很好的理由不重置您的增量variables内的VBA For ... Next ; a）陷入无限循环b）不重置循环的结束意味着无用的迭代是其中的两个。 还有其他的原因。 一般来说这不是很好的编程方法。 在上面的方法中，我不必担心自上而下的进行，因为我正在离开被单独检查的行并删除所有其他匹配; 而不是相反。 当被检查的行不再有任何价值时，我也有退出。
我对这个超越智力活动的目的有点好奇。 51行> 5000行只有0或1的select，那么在删除匹配的三元组集合之后，很less有剩余的可能性。 也许你可以在评论中甚至是你原来的文章中对这个主题进行一些扩展。