Необходимо удаление/выделение дублей в таблице

Sub BALANS()
 
   Dim Debit: Set Debit = CreateObject("Scripting.Dictionary")  ' Создаем словарь
   Dim Kredit: Set Kredit = CreateObject("Scripting.Dictionary")  ' Создаем словарь
Dim M
M = Range(Cells(8, 3), Cells(Cells(Rows.Count, 3).End(xlUp).Row, 7))
For r = 1 To UBound(M)
    If M(r, 4) <> "" Then
        If Debit.exists(M(r, 4)) Then
            Debit.Item(M(r, 4)) = Debit.Item(M(r, 4)) + 1
        Else
            Debit.Add M(r, 4), 1
        End If
    End If
Next r
 
For r = 1 To UBound(M)
    If M(r, 5) <> "" Then
        If Debit.exists(M(r, 5)) Then
             If Debit.Item(M(r, 5)) > 1 Then
             Debit.Item(M(r, 5)) = Debit.Item(M(r, 5)) - 1
             Else
             Debit.Remove (M(r, 5))
             End If
        Else
            Kredit.Add M(r, 5), 1
        End If
    End If
Next r
M = Debit.keys
 
s = "Непогашенные суммы Увеличения:" & vbCrLf
For r = 0 To UBound(M) - 1
s = s & M(r) & vbCrLf
Next r
 
s = s & "Непогашенные суммы Уменьшения:" & vbCrLf
M = Kredit.keys
For r = 0 To UBound(M) - 1
s = s & M(r) & vbCrLf
Next r
 
MsgBox s, 64, ""

Option Explicit
Sub Procedure_1()
 
    'Здесь нужно указать, с какой строки начинаются данные.
    Const lStartRow As Long = 8
 
    Dim lLastRow As Long
    Dim i As Long
    Dim rFind As Excel.Range
    
    'Определяем последнюю заполненную строку.
    'Последнюю строку определяю по столбцу "B".
    'Действие кода будет аналогично, если сделать активной
    'ячейку "B7" и нажать сочетание клавиш Ctrl+стрелка вниз.
    lLastRow = Range("B7").End(xlDown).Row
    
    'Скрываем мерцание экрана.
    Application.ScreenUpdating = False
    
    'Двигаемся сверху вниз по столбцу "F".
    'Просматриваем каждую ячейку столбца "F" и ищем
    'одинаковое числов в столбце "G".
    For i = 8 To lLastRow Step 1
        
        'Принимаем во внимание только ячейки с числами.
        'Считается, что пустые ячейки тоже содержат число (ноль),
        'поэтому нужно учесть, что ячейка может быть пустой.
        
        If IsNumeric(Cells(i, "F").Value) = True And _
                IsEmpty(Cells(i, "F").Value) = False Then
                
            'Осуществляем поиск в столбце "G".
            'After:=Range("G" & lLastRow) - чтобы поиск начинался с первой ячейки
            'в заданном диапазоне, а не со второй.
            Set rFind = Range("G" & lStartRow & ":G" & lLastRow).Find(What:=Cells(i, "F").Formula, _
                    After:=Range("G" & lLastRow), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
                    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
                
            'Если совпадение найдено, то скрываем 2 строки.
            If Not rFind Is Nothing Then
                Rows(i).Hidden = True
                Rows(rFind.Row).Hidden = True
            End If
                    
        End If
    
    Next i
    
    'Включаем обновление монитора.
    Application.ScreenUpdating = True
    
    'Сообщение, что работа завершена.
    MsgBox "Работа завершена!", vbCritical
 
End Sub

Sub BALANS()
 
   Dim Debit: Set Debit = CreateObject("Scripting.Dictionary")  ' Создаем словарь
   Dim Kredit: Set Kredit = CreateObject("Scripting.Dictionary")  ' Создаем словарь
Dim M
M = Range(Cells(8, 3), Cells(Cells(Rows.Count, 3).End(xlUp).Row, 7))
For r = 1 To UBound(M)
    If M(r, 4) <> "" Then
        If Debit.exists(M(r, 4)) Then
            Debit.Item(M(r, 4)) = Debit.Item(M(r, 4)) + 1
        Else
            Debit.Add M(r, 4), 1
        End If
    End If
Next r
 
For r = 1 To UBound(M)
    If M(r, 5) <> "" Then
        If Debit.exists(M(r, 5)) Then
             If Debit.Item(M(r, 5)) > 1 Then
             Debit.Item(M(r, 5)) = Debit.Item(M(r, 5)) - 1
             Else
             Debit.Remove (M(r, 5))
             End If
        Else
        
            If Kredit.exists(M(r, 5)) Then
                Kredit.Item(M(r, 5)) = Kredit.Item(M(r, 5)) + 1
            Else
                Kredit.Add M(r, 5), 1
            End If
        End If
    End If
Next r
M = Debit.keys
 
s = "Непогашенные суммы Увеличения:" & vbCrLf
For r = 0 To UBound(M) - 1
s = s & M(r) & vbCrLf
Next r
 
s = s & "Непогашенные суммы Уменьшения:" & vbCrLf
M = Kredit.keys
For r = 0 To UBound(M) - 1
s = s & M(r) & vbCrLf
Next r
 
MsgBox s, 64, ""

Sub www()
    Dim m, a, b, i&, n&, j&
    Range(Cells(8, 6), Cells(Cells(Rows.Count, 3).End(xlUp).Row, 7)).EntireRow.Hidden = 0
    m = Range(Cells(8, 6), Cells(Cells(Rows.Count, 3).End(xlUp).Row, 7))
    ReDim a(1 To UBound(m), 1 To 2)
    With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(m)
        If m(i, 1) <> "" Then
            If .exists(m(i, 1)) Then
                a(.Item(m(i, 1)), 1) = a(.Item(m(i, 1)), 1) & "|" & i
            Else
                n = n + 1
                .Item(m(i, 1)) = n
                a(n, 1) = i
            End If
        End If
    Next i
 
    For i = 1 To UBound(m)
        If m(i, 2) <> "" Then
            If .exists(m(i, 2)) Then
                j = .Item(m(i, 2))
                a(j, 2) = IIf(a(j, 2) <> "", a(j, 2) & "|" & i, i)
            Else
                n = n + 1
                .Item(m(i, 2)) = n
                a(n, 2) = i
            End If
        End If
    Next i: End With
    Application.ScreenUpdating = 0
    For i = 1 To n
        If a(i, 1) <> "" And a(i, 2) <> "" Then
            m = Split(a(i, 1), "|")
            b = Split(a(i, 2), "|")
            For j = 0 To Application.Min(UBound(m), UBound(b))
                Rows(m(j) + 7).Hidden = -1
                Rows(b(j) + 7).Hidden = -1
            Next
        End If
    Next
    Application.ScreenUpdating = -1
End Sub

For i = 1 To UBound(m)

For i = UBound(m) To 1 Step -1