Error with a loop that copy data and delete row - excel

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...