'Включаем обязательное объявление переменных
Option Explicit
Private Sub CommandButton1_Click()

'Отключаем некоторые функции экселя для ускорения работы
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

'Объявляем переменные
Dim a(), a1(), b As Range, bord1$, i&, ii&, lwr&, t$

bord1 = "*#*#*"

lwr = Cells(Rows.Count, 1).End(xlUp).Row
Set b = Range(Cells(3, 1), Cells(lwr, 2))
'a = Range(Cells(3, 1), Cells(lwr, 2)).Value лучше так
a = b.Value
ReDim a1(1 To UBound(a), 1 To 2)

With CreateObject("scripting.dictionary")
    
    'Удаляем пробелы, плюсы, дубликаты
    For i = 1 To UBound(a)
        a(i, 2) = Replace(a(i, 2), " ", "")
        t = Replace(a(i, 1), "+", "")
        If Not .exists(t) Then
            .Item(t) = ""
            ii = ii + 1
            a1(ii, 1) = t: a1(ii, 2) = a(i, 2)
        End If
    Next
    
    'Удаляем статистику, цифры
    For i = 1 To UBound(a)
        If a(i, 1) = "Статистика по словам" Or a(i, 1) Like bord1 Then
            a(i, 1) = ""
            a(i, 2) = ""
        End If
    Next
    
End With

With b
    .Clear
    .Resize(ii, 2).Value = a1
End With

Set b = Nothing
Erase a
Erase a1

'Включаем функции экселя
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True

End Sub