复制数据并删除行的循环出错

Question

我写了一个脚本以在Colomn B中找到重复值。它们可以是很多重复：

Value1 Value2 value3 Value1 Value2

，但不超过两次。我需要从b列的第二个重复的C列到M列的值，然后将其粘贴到第一个重复C到M列。之后，我需要删除第二个重复行。

该脚本仅用于重复的一个实例。.

Sub hi()
    Dim lastRow As Long
    Dim matchFoundIndex As Long
    Dim iCntr As Long
    lastRow = Range("B100").End(xlUp).Row
    
    For iCntr = 6 To lastRow
    If Cells(iCntr, 2) <> "" Then
        matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 2), Range("B1:B" & lastRow), 0)
        If iCntr <> matchFoundIndex Then
        
            Cells(iCntr, 3).Copy
            Cells(matchFoundIndex, 3).Select
            ActiveSheet.Paste
            
            Cells(iCntr, 4).Copy
            Cells(matchFoundIndex, 4).Select
            ActiveSheet.Paste
            
            Cells(iCntr, 5).Copy
            Cells(matchFoundIndex, 5).Select
            ActiveSheet.Paste
            
            
            Cells(iCntr, 6).Copy
            Cells(matchFoundIndex, 6).Select
            ActiveSheet.Paste
            
            
            Cells(iCntr, 7).Copy
            Cells(matchFoundIndex, 7).Select
            ActiveSheet.Paste
            
            
            Cells(iCntr, 8).Copy
            Cells(matchFoundIndex, 8).Select
            ActiveSheet.Paste
            
            Cells(iCntr, 9).Copy
            Cells(matchFoundIndex, 9).Select
            ActiveSheet.Paste
            
            
            Cells(iCntr, 10).Copy
            Cells(matchFoundIndex, 10).Select
            ActiveSheet.Paste
            
            Cells(iCntr, 11).Copy
            Cells(matchFoundIndex, 11).Select
            ActiveSheet.Paste
            
            
            Cells(iCntr, 12).Copy
            Cells(matchFoundIndex, 12).Select
            ActiveSheet.Paste
            
            
            Cells(iCntr, 13).Copy
            Cells(matchFoundIndex, 13).Select
            ActiveSheet.Paste
            
            Rows(iCntr).EntireRow.Delete
            
       End If
    End If
    Next
End Sub

您能帮我清洁此脚本吗？谢谢 ！

Answer 1

请尝试使用下一个代码。它使用词典将第一次出现的行保留，并将第二个出现的范围c：m复制到第一个。它在不选择剪贴板的情况下以快速的方式进行操作。所有第二次出现的细胞都将其放置在联合范围内，并立即删除。实际上，实际代码仅选择包含第二次出现的行。 如果它根据需要返回，则只需在最后一个代码行中替换 delete ：

Sub hi()
    Dim lastRow As Long, iCntr As Long, rngDel As Range, dict As Object
    
    lastRow = Range("B" & rows.count).End(xlUp).row
    Set dict = CreateObject("Scripting.Dictionary")
    
    For iCntr = 6 To lastRow
      If cells(iCntr, 2) <> "" Then
          If Not dict.Exists(cells(iCntr, 2).value) Then
              dict.Add cells(iCntr, 2).value, iCntr 'the first occurrence row as item
          Else
              'copy the C:M range to the row of the first occurrence
              Range("C" & dict(cells(iCntr, 2).value) & ":M" & dict(cells(iCntr, 2).value)).value = _
                                                                      Range("C" & iCntr & ":M" & iCntr).value
              If rngDel Is Nothing Then
                  Set rngDel = cells(iCntr, 2)
              Else
                  Set rngDel = Union(rngDel, cells(iCntr, 2))
              End If
          End If
    End If
 Next
 If Not rngDel Is Nothing Then rngDel.EntireRow.Select 'if selected what you need, replace Select with Delete
End Sub

上述代码复制<的行强>第二次出现（C：M）到第一个行。否则，复制以要删除的行上的任何内容将没有任何意义...