Question

我遇到此代码的问题：

Sub text() 

Dim iListCount As Integer 
Dim x As Variant 
Dim iCtr As Integer

' Turn off screen updating to speed up macro. 
Application.ScreenUpdating = False

' Get count of records to search through (list that will be deleted). 
iListCount = Sheets("sheet2").Cells(Rows.Count, "C").End(xlUp).Row

' Loop through the "master" list. 
For Each x In Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Row) 
      ' Loop through all records in the second list. 
      For iCtr = iListCount To 1 Step -1 
         ' Do comparison of next record. 
         ' To specify a different column, change 1 to the column number. 
         If x.Value = Sheets("Sheet2").Cells(iCtr, 3).Value Then 
         ' If match is true then delete row. 
          Sheets("Sheet2").Cells(iCtr, 1).EntireRow.Delete 
          End If 
        Next iCtr 
Next 
Application.ScreenUpdating = True 
MsgBox "Done!" 
End Sub

它运行，并且有点工作。它删除了一个副本，但保留了所有其他副本。我正在测试这个，所以我使用的是一个小样本，因此我知道有5个重复项，但是我无法将这些代码全部删除。有任何想法吗？我认为这是循环的一个问题，但无论我改变什么，我都无法让它工作

Answer 1

通过删除内部循环中的整行，您将修改外部循环在循环中间循环的范围。这样的代码很难调试。

您的嵌套循环结构本质上是一系列线性搜索。这使得整体行为在行数上呈二次方，并且可以使应用程序变慢。一种方法是使用可以在VBA中使用的dictionary，如果您的项目包含对Microsoft Scripting Runtime的引用（工具 - VBA编辑器中的引用）

以下子使用字典删除C列中具有在A列中出现的值的所有单元格：

Sub text()
    Dim MasterList As New Dictionary
    Dim iListCount As Integer
    Dim x As Variant
    Dim iCtr As Integer
    Dim v As Variant

    Application.ScreenUpdating = False

    ' Get count of records in master list
    iListCount = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row
    'Load Dictionary:
    For iCtr = 1 To iListCount
        v = Sheets("sheet2").Cells(iCtr, "A").Value
        If Not MasterList.Exists(v) Then MasterList.Add v, ""
    Next iCtr

    'Get count of records in list to be deleted
    iListCount = Sheets("sheet2").Cells(Rows.Count, "C").End(xlUp).Row

    ' Loop through the "delete" list.
        For iCtr = iListCount To 1 Step -1
            If MasterList.Exists(Sheets("Sheet2").Cells(iCtr, "C").Value) Then
                Sheets("Sheet2").Cells(iCtr, "C").Delete shift:=xlUp
            End If
        Next iCtr
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

Answer 2

另一种选择是遍历单元格，使用Find和FindNext查找重复项，并使用Union()将它们添加到范围中。然后，您可以在例程结束时删除该范围。这解决了在迭代行时删除行的问题，并且应该很快执行。

注意：此代码未经测试，您可能需要对其进行调试。

Sub text() 

    Dim cell As Range
    Dim lastCell as Range
    Dim masterList as Range
    Dim matchCell as Range
    Dim removeUnion as Range
    Dim firstMatch as String

    ' Turn off screen updating to speed up macro. 
    Application.ScreenUpdating = False

    With Sheets("sheet2").Range("A:A")
    ' Find the last cell with data in column A
        Set lastCell = .Find("*", .Cells(1,1), xlFormulas, xlPart, xlByRows, xlPrevious)
    ' Set the master list range to the used cells within column A
        Set masterList = .Range(.cells(1,1) , lastCell)
    End With

    ' Loop through the "master" list. 
    For Each cell In masterList
    ' Look for a match anywhere within column "C"
         With cell.Parent.Range("C:C")
             Set matchCell = .Find(.Cells(1,1), cell.Value, xlValues, xlWhole, xlByRows)

             'If we got a match, add it to the range to be deleted later and look for more matches
             If Not matchCell is Nothing then

                 'Store the address of first match so we know when we are done looping
                 firstMatch = matchCell.Address

                 'Look for all duplicates, add them to a range to be deleted at the end
                 Do 
                     If removeUnion is Nothing Then
                         Set removeUnion = MatchCell
                     Else
                         Set removeUnion = Application.Union(removeUnion, MatchCell)
                     End If
                     Set MatchCell = .FindNext
                 Loop While (Not matchCell Is Nothing) and matchCell.Address <> firstMatch
              End If
              'Reset the variables used in find before next loop
              firstMatch = ""
              Set matchCell = Nothing

         End With

    Next 

    If Not removeUnion is Nothing then removeUnion.EntireRow.Delete

    Application.ScreenUpdating = True 
    MsgBox "Done!" 
End Sub

从Excel

2 个答案: