Question

我有和excel填充0和1像这样： Excel

我希望找到哪些行与其他行共有三（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的初学者，我不知道这段代码是否有效，但我没有找到任何其他方法来解决问题，我也想到了在C中执行此程序（只解析CSV）。

Answer 1

看看这是否会为你加速。在A2上测试：AY5000填充=RANDBETWEEN(0,1)然后复制＆amp;粘贴特殊值。第1行是带有列标签的标题行。您需要重命名工作表 Matriz 或修改命名工作表的代码行。

5000×51 ones and zeroes

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

results

您自己的经过时间将在很大程度上取决于1和0的比率。如果RANDBETWEEN运行正常，我的约为50％/ 50％。更多的零意味着必须检查更多的行和列。您可以检查VBE的立即窗口以查看已删除的行数。

有充分的理由不在VBA For ... Next中重置增量变量; a）陷入无限循环并且b）不重置循环的结束意味着无用的迭代是其中两个。还有其他原因;一般来说，这不是一个好的编程方法。在上面的方法中，我不必担心从上到下进行，因为我将单独检查行并删除所有其他匹配;而不是相反。当被检查的行不再有任何值时，我也有一个退出。

除了智力锻炼之外，我对这个目的有点好奇。对于51列> 5000行且只能选择 0 或 1 ，在删除匹配的三元组之后，似乎很少有剩余的可能性。也许你可以在评论甚至原始帖子中稍微扩展一下这个主题。

加速VBA代码以查找具有相似数字出现次数的行

1 个答案: