Поиск совпадений в 2х столбцах и добавление пустой строки - VBA - Ответ 4617029

Sub New_InsertRows()
Dim i&, mARR(), counter&, currCell As Range
Dim dict As Object, mRng As Range
    Set dict = CreateObject("scripting.dictionary")
        With ActiveSheet
            Set mRng = Range(.Cells(1, 3), .Cells(.UsedRange.Row - 1 + _
                    .UsedRange.Rows.Count, .UsedRange.Column - 1 + _
                                            .UsedRange.Columns.Count))
        End With
    counter = 0
    Application.ScreenUpdating = False
    For Each currCell In mRng.Cells
        If dict.exists(Trim(currCell.Value)) Then
            counter = counter + 1
            ReDim Preserve mARR(1 To counter)
            mARR(counter) = currCell.Row
            currCell.Interior.ColorIndex = 16 ' 9
                Else: dict.Add Trim(currCell.Value), 0&
        End If
    Next 'i
    counter = 0: Set dict = Nothing
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Len(Cells(i, 1)) Then
            counter = counter + 1
                Cells(i, 2).Value = counter
        End If
    Next 'i
    For i = UBound(mARR) To LBound(mARR) Step -1
        If Application.WorksheetFunction. _
            CountA(Rows(mARR(i) + 1)) <> 0 Then
            Rows(mARR(i) + 1).Insert Shift:=xlDown
            Rows(mARR(i) + 1).Interior.ColorIndex = xlNone
        End If
    Next 'i
    Erase mARR
    Application.ScreenUpdating = True
    MsgBox Space(12) & "D O N E!"
End Sub