使用 Excel VBA 改进 Cycles 数据

Question

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

问题是我有一个table，其中出现了递归数据，我必须只删除其中一个。这是一个例子，在这个table中，可以看到，可能有循环数据：

因此，在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

Answer 2

这是我最后一次修改代码，感谢@omegastripes

Sub CycleFind3()

    Dim rFound As Range
    Dim sLookfor As String
    Dim rCell As Range
    Dim rowFlast As Long
    Dim rowF 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
    rowFlast = Cells(Rows.Count, 6).End(xlUp).Row + 1
    Set rowF = Range(Cells(rowFlast, 6), Cells(rowFlast, 6))
            With rowF.Select
                ' Get D value
      sLookfor = rowF.Offset(0, -2).Value
            rowF.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

Answer 3

我相信你是过度思考过程和过度处理方法。

如果您采用前三列的数组并从前三列构建第四个串联列，则如果将 C-A-B 与 C-B-A 进行比较，您可能会出现一些重复。但是，如果您构建前两列已排序的串联列，则 C-A-B 和 C-B-A 都会产生相同的结果。

Option Explicit

Sub cycleFind4()
    Dim i As Long, j As Long, arr As Variant, val As Variant

    With Worksheets("LOCID")

        'collect values from worksheet
        arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "C").End(xlUp)).Value2

        'add an extra 'column' to the array
        ReDim Preserve arr(LBound(arr, 1) To UBound(arr, 1), _
                           LBound(arr, 2) To UBound(arr, 2) + 1)

        'populate a single laterally-sorted concat field
        For i = LBound(arr, 1) To UBound(arr, 1)
            If CStr(arr(i, 1)) < CStr(arr(i, 2)) Then
                arr(i, 4) = Join(Array(arr(i, 3), arr(i, 1), arr(i, 2)), vbNullString)
            Else
                arr(i, 4) = Join(Array(arr(i, 3), arr(i, 2), arr(i, 1)), vbNullString)
            End If
        Next i

        'return array to worksheet
        .Cells(2, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

        'remove duplicates from bottom-to-top
        With .Cells(1, "A").CurrentRegion
            .RemoveDuplicates Columns:=Array(4), Header:=xlYes
        End With
    End With
End Sub

大约一秒钟处理了 47K 条记录。

使用 Excel VBA 改进 Cycles 数据

Improve Cycles data with Excel VBA

vba

excel

cycle