Sub www()
    Dim r&, a, i&, n&, aa
    Dim DictInp As Object: Set DictInp = CreateObject("Scripting.Dictionary"): DictInp.CompareMode = vbTextCompare
    Columns(3).ClearContents
    a = Cells(2).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2).Value
    On Error Resume Next
    For i = 1 To UBound(a)
        If DictInp.exists(a(i, 1)) Then
            DictInp.Item(a(i, 1)) = DictInp.Item(a(i, 1)) + 1
        Else
            DictInp.Add a(i, 1), a(i, 2)
        End If
    Next
    aa = DictInp.keys
    For i = 1 To UBound(a)
        For n = 1 To DictInp.Count
            If a(i, 1) = aa(n) Then a(i, 2) = DictInp.Item(aa(n))
        Next: Next
    Cells(2).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2).Value = a
Cells(1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 3).Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess
End Sub

Sub Макрос1()
    Dim i&, j&, lRow&, lRow2&
    Dim arr, arr2
    Application.ScreenUpdating = False

    
    With Sheets("Таблица")
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("C2:C" & lRow).FormulaR1C1 = "=LEN(RC[-2])"
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("C2:C" & lRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange Range("A2:C" & lRow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        arr = .Range("A2:B" & lRow).Value
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual
    With Sheets("Лист1")
        lRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
        arr2 = .Range("A2:B" & lRow2).Value
    End With
    
    For j = LBound(arr2) To UBound(arr2)
        For i = LBound(arr) To UBound(arr)
            If (arr2(j, 1) Like arr(i, 1) & "*") Then
                arr2(j, 2) = arr(i, 2)
                Exit For
            End If
        Next i
        
        With Application
            .StatusBar = j
        End With
    Next j
'
'    For i = LBound(arr) To UBound(arr)
'        For j = LBound(arr2) To UBound(arr2)
'            If (arr2(j, 1) Like "*" & arr(i, 1) & "*") And arr2(j, 2) = "" Then
'                arr2(j, 2) = arr(i, 2)
'            End If
'            If (Sheets("Лист1").Cells(j, "A") Like "*" & Sheets("Таблица").Cells(i, "A") & "*") And _
'                Sheets("Лист1").Cells(j, "B") = "" Then
'                Sheets("Лист1").Cells(j, "B") = Sheets("Таблица").Cells(i, "B")
'            End If
'        Next j
'    Next i
    
    Sheets("Лист1").Range("A2:B" & lRow2) = arr2
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationAutomatic
    
    With Sheets("Таблица")
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("B2:B" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A2:C" & lRow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Columns(3).ClearContents
    End With

    Application.ScreenUpdating = True
End Sub

Sub Макрос1()
    Dim i&, j&, lRow&, lRow2&
    
    Application.ScreenUpdating = False
    
    With Sheets("Таблица")
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("C2:C" & lRow).FormulaR1C1 = "=LEN(RC[-2])"
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("C2:C" & lRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange Range("A2:C" & lRow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    
    With Sheets("Лист1")
        lRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    For i = 2 To lRow
        For j = 2 To lRow2
            If (Sheets("Лист1").Cells(j, "A") Like "*" & Sheets("Таблица").Cells(i, "A") & "*") And _
                Sheets("Лист1").Cells(j, "B") = "" Then
                Sheets("Лист1").Cells(j, "B") = Sheets("Таблица").Cells(i, "B")
            End If
        Next j
    Next i
    
    With Sheets("Таблица")
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("B2:B" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A2:C" & lRow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Columns(3).ClearContents
    End With
    Application.ScreenUpdating = True
End Sub