Question

我有一个170K行的工作簿，当单元格之间的结果为0时，我将删除所有行对于那些操作，通常我使用下面的代码，但是170K（行将被删除为90K）代码运行速度非常慢。
有人知道另一种方式更多的表现。感谢

Last = Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
   If (Cells(i, "K").Value + Cells(i, "L").Value) < 1 Then
       Cells(i, "A").EntireRow.Delete
   End If
Next i

Answer 1

只要您将数据放在新选项卡上就可以了，下面的代码将在1.5秒内完成您需要的所有操作。

Sub ExtractRows()

Dim vDataTable As Variant
Dim vNewDataTable As Variant
Dim vHeaders As Variant
Dim lastRow As Long
Dim i As Long, j As Long
Dim Counter1 As Long, Counter2 As Long

With Worksheets(1)
    lastRow = .Cells(Rows.Count, "K").End(xlUp).row
    vHeaders = .Range("A1:L1").Value2
    vDataTable = .Range("A2:L" & lastRow).Value2
End With

For i = 1 To UBound(vDataTable)
    If vDataTable(i, 11) + vDataTable(i, 12) > 0 Then
        Counter1 = Counter1 + 1
    End If
Next

ReDim vNewDataTable(1 To Counter1, 1 To 12)
For i = 1 To UBound(vDataTable)
    If vDataTable(i, 11) + vDataTable(i, 12) > 0 Then
        Counter2 = Counter2 + 1
        For j = 1 To 12
            vNewDataTable(Counter2, j) = vDataTable(i, j)
        Next j
    End If
Next

Worksheets.Add After:=Worksheets(1)

With Worksheets(2)
    .Range("A1:L1") = vHeaders
    .Range("A2:L" & Counter1 + 1) = vNewDataTable
End With

End Sub

Answer 2

在这里，我根据rwilson's想法解决您的问题。

我已经测试过了。它非常非常简化执行时间。试试吧。

Sub deleteRow()

    Dim newSheet As Worksheet
    Dim lastRow, newRow As Long
    Dim sheetname As String
    Dim startTime As Double

    sheetname = "sheetname"

    With Sheets(sheetname)

        Set newSheet = ThisWorkbook.Worksheets.Add(After:=Sheets(.Name))

        'Firstly copy header
        newSheet.Rows(1).EntireRow.Value = .Rows(1).EntireRow.Value

        lastRow = .Cells(.Rows.Count, "K").End(xlUp).row

        newRow = 2

        For row = 2 To lastRow Step 1

            If (.Cells(row, "K").Value + .Cells(row, "L").Value) >= 1 Then

                newSheet.Rows(newRow).EntireRow.Value = .Rows(row).EntireRow.Value

                newRow = newRow + 1

            End If

        Next row

    End With

    Application.DisplayAlerts = False
    Sheets(sheetname).Delete
    Application.DisplayAlerts = True

    newSheet.Name = sheetname

End Sub

Answer 3

您可以尝试以下非VBA选项：

在列M中计算列K和L的总和
突出显示列M并单击Find and select > Find
在0框中输入Find what，然后在values框中选择Look in
选择Find all，然后在显示找到的项目的框中选择所有项目（在框中单击并按CTRL + A）
在功能区上选择Delete，然后选择Delete sheet rows
现在手动删除列M

我还没试过170k +行，但可能值得评估性能与VBA循环。

Answer 4

非常感谢您的想法，但真正快速的代码是：使用数组tu填充正确的日期并重新排列表的最终排序表：

Sub Macro13(control As IRibbonControl)
Dim avvio As Date
Dim arresto As Date
Dim tempo As Date

Application.ScreenUpdating = False
Application.Calculation = xlManual
avvio = Now()
    Dim sh As Worksheet
    Dim arng As Variant
    Dim arrdb As Variant
    Dim UR As Long, x As Long, y As Long
    Dim MyCol As Integer

    Set sh = Sheets("Rol_db")
    MyCol = 1
    sh.Select
    UR = sh.Cells(Rows.Count, MyCol).End(xlUp).Row
    ReDim arrdb(2 To UR, 1 To 12) As Variant
    For x = 2 To UR
    If Cells(x, 11) + Cells(x, 12) > 0 Then
        For y = 1 To 12
            arrdb(x, y) = Cells(x, y)
        Next y
    Else
        For y = 1 To 12
            arrdb(x, y) = ""
        Next y
    End If
Next x
    sh.Range("A2:L" & UR) = arrdb

arresto = Now()
tempo = arresto - avvio
Debug.Print "Delete empty rows " & tempo

Range("A2:L" & UR).Sort key1:=Range("A2:L" & UR), _
   order1:=xlAscending, Header:=xlNo

    Range("A4").Select
    ActiveWindow.FreezePanes = True
conclusioni:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

我的表170K 00:00:07的时间。只要我有一分钟，我就感觉到了一个列的循环

如何更改我的代码以更快速地运行它？

4 个答案: