vba - 使用 Excel VBA 改进 Cycles 数据

Question

我需要帮助来改进此代码，因为使用大量数据执行它很慢。

问题是我有一个表，其中出现了递归数据，我只需要删除其中一个。这是一个例子，在这张表中，可以看到，可能有周期性数据:



因此，在 D 列和 E 列中连接，将 D 复制到 F 列，然后在 E 列找到 F 值，如果找到则删除整行。



我是这样做的，否则，我删除了两个周期，我需要保留一个。它一直重复，直到宏在 A 列中找到一个空白单元格。这是我编写的代码:

Sub CycleFind3()

    Dim rFound As Range
    Dim lookfor As String
    Dim xCell As Range

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Sheets("LOCID").Select
DoItAgain:
    Range("A1").Select
    ' Select empty cell on F and move to A to verify if its empty
    For Each xCell In ActiveSheet.Columns(6).Cells
        If Len(xCell) = 0 Then
            xCell.Select
            Exit For
        End If
    Next
    ActiveCell.Offset(0, -5).Select
    If Not IsEmpty(ActiveCell.Value) Then
    Else
        Exit Sub ' if Axx is empty, exit the sub
    End If
    ' Select last cell used in G
    Range("F1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ' then copy D value
    ActiveCell.Offset(0, -2).Copy
    ActiveCell.PasteSpecial
    Application.CutCopyMode = False
    ' looking for F value at E column
    lookfor = ActiveCell
    Set rFound = ActiveSheet.Range("E:E").Find(What:=lookfor, LookIn:= _
        xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False)
    If rFound Is Nothing Then
        ' if not found start again to do the same to follow row
        GoTo DoItAgain
    Else
        ' If find F in E delete row
        rFound.Select
        ActiveCell.EntireRow.Delete
    End If
    ' repeat until A is blank cell
    GoTo DoItAgain

End Sub

如何改进以优化执行时间？

Answer 1

考虑下面的例子:

Option Explicit

Sub CycleFind3()

    Dim rFound As Range
    Dim sLookfor As String
    Dim rCell As Range

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    With Sheets("LOCID")
        .Select
        Do
            ' Repeat until A is blank cell
            For Each rCell In .Columns(6).Cells
                ' Get empty cell on F and verify if A is empty
                If IsEmpty(rCell.Value) Then
                    ' If A is empty, exit the sub
                    If IsEmpty(rCell.Offset(0, -5).Value) Then Exit Do
                    Exit For
                End If
            Next
            ' Last cell used in F
            With .Range("F1048576").End(xlUp).Offset(1, 0)
                ' Get D value
                sLookfor = .Offset(0, -2).Value
                .Value = sLookfor
            End With
            ' Looking for F value at E column
            Set rFound = .Range("E:E").Find(What:=sLookfor, LookIn:= _
                xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
                xlNext, MatchCase:=False, SearchFormat:=False)
            If Not rFound Is Nothing Then
                ' If find F in E delete row
                rFound.EntireRow.Delete
            End If
        Loop
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub