Question

我在做代码。

Sub DeleteProjectDuplicate()
    Dim BaseWorkbook As Workbook
    Set BaseWorkbook = ThisWorkbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Dim i, j As Long
    Dim needDelete As Boolean
    i = 4
        Do While BaseWorkbook.Sheets("Project Info").Cells(i, 10).Value <> ""
            needDelete = False
                For j = 3 To i - 1
                    If BaseWorkbook.Sheets("Project Info").Cells(i, 10).Value = BaseWorkbook.Sheets("Project Info").Cells(j, 10).Value Then
                        needDelete = True

                        If BaseWorkbook.Sheets("Project Info").Cells(i, 7).Value > BaseWorkbook.Sheets("Project Info").Cells(j, 7).Value Then
                            BaseWorkbook.Sheets("Project Info").Cells(j, 7).Value = BaseWorkbook.Sheets("Project Info").Cells(i, 7).Value
                        End If
                        Exit For
                    End If
                Next j
                If needDelete Then
                    BaseWorkbook.Worksheets("Project Info").Rows(i).EntireRow.Delete
                Else
                    i = i + 1
                End If
        Loop
    MsgBox ("Complete")
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

它可以工作但是对于大数据来说，它需要很长时间才能处理。如何才能更好地改进它。

Answer 1

请记住，在许多情况下，删除工作表中的大量数据可能会非常昂贵，因为它可能会占用大量处理能力。这可能是您代码中最费力的部分。

我对您的代码做了一些重大改进我没有直接从工作表中读取单元格，而是将数据添加到多维数组中。我们将在那里比较值。

另外，不要一次删除一行;相反，创建一个跟踪要删除的行的特殊范围，然后一次删除它们。

此外，由于您不再对工作表进行无数的读/写操作，因此您不再需要担心应用程序的ScreenUpdating和Calculation属性，因此我删除了这些属性。

看看这个，你应该看到一些不错的改进：

Sub DeleteProjectDuplicate()

    Dim wsProjectInfo As Worksheet  '<-- No need to set ThisWorkbook, declare the ws instead
    Set wsProjectInfo = ThisWorkbook.Worksheets("Project Info")

    Application.EnableEvents = False

    Dim i As Long   '<-- no need to use 'j'
    Dim wsDataArr() As Variant, delRng As Range
    wsDataArr = wsProjectInfo.UsedRange.Value   '<-- move your data to an array

    With wsProjectInfo
        For i = 3 To UBound(wsDataArr) - 1
            If wsDataArr(i, 10) = wsDataArr(i + 1, 10) Then
                If delRng Is Nothing Then
                    Set delRng = .Rows(i + 1)
                Else
                    Set delRng = Union(delRng, .Rows(i + 1))
                End If
                If wsDataArr(i + 1, 7) > wsDataArr(i, 7) Then
                    wsDataArr(i, 7) = wsDataArr(i + 1, 7)   '<-- Write data to array, not ws
                End If
            End If
        Next
        .UsedRange = wsDataArr  '<-- rewrite the worksheet with updated data
    End With

    If Not delRng Is Nothing Then delRng.Delete '<-- Delete your rows all at once

    MsgBox "Complete"
    Application.EnableEvents = True

End Sub

如果找到，如何快速搜索然后更新/删除行

1 个答案: