Error with a loop that copy data and delete row

Question

I wrote a script to find duplicate values in Colomn B. They can be alot of duplicates :

Value1 Value2 Value3 Value1 Value2

But never more than twice. I need to get the values from C column to M column from the second duplicate of B column and paste it on the first duplicate C to M column. After, i need to delete the second duplicate row.

The script work only for one instance of duplicate..

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

Can you please help me clean this script ! Thank you !

Answer 1

Please, try using the next code. It uses a dictionary to keep the row of the first occurrence and copy the range C:M of the second occurrence to the first one. It does it without selecting, without using clipboard, in a fast way. All second occurrence cells are placed in a union range and deleted at the end, at once. In fact, the actual code only selects the rows containing the second occurrence. If it returns as you need, you only have to replace Select with Delete in the last code line:

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

The above code copies the rows of the second occurrence (C:M) to the row of the first one. Otherwise, it will not make any sense to copy anything on rows to be deleted...