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

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改善周期数据

3 个答案: