Создать макрос для автоматического поиска названия по числам

[Mishael]

Здравствуйте уважаемые программисты  нужна помощь :

Есть таблица в ней - лист 2 числа, а на листе 1 те же числа но с названиями нужно, что бы программа (макрос) нашла по цифрам названия и поставила в соответствующий столбик к числу на втором листе (образец лист 3), а на месте повторяющихся названий писала повтор ну или ошибка без разницы.
Спасибо заранее за помощь.

[Mishael]

ну помогите же пожалуйста

[staniiislav]

если правильно понял, немного набросал:

Option Explicit

Sub Extract_Unique1()
   Dim vItem, arr, x, i&, j&, n&
   Range("D5", Cells(Rows.Count, "E").End(xlUp)).ClearContents
   With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare
      For Each vItem In Sheets("Лист1").Range("B5", Sheets("Лист1").Cells(Rows.Count, "B").End(xlUp)).Value
         If Not .Exists(vItem) And Not IsEmpty(vItem) Then .Item(vItem) = .Item(vItem)
      Next
      ReDim arr(1 To .Count, 1 To 1)
      'If .Count Then [D5].Resize(.Count).Value = Application.WorksheetFunction.Transpose(.Keys)
      If .Count Then arr = Application.WorksheetFunction.Transpose(.Keys)
   End With
   
   x = Sheets("Лист1").Range("A5", Sheets("Лист1").Cells(Rows.Count, "B").End(xlUp)).Value
   
   For i = 1 To UBound(arr)
    For j = 1 To UBound(x)
        If arr(i, 1) = x(j, 2) Then
            n = n + 1
            If n > 1 Then x(j, 1) = "повтор"
        End If
    Next j
    n = 0
   Next i
   
   [D5].Resize(UBound(x), 2).Value = x
   Call Макрос1
End Sub


Sub Макрос1()
'
' Макрос1 Макрос
'

'
    ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add Key:=Range("E5", Cells(Rows.Count, "E").End(xlUp)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист2").Sort
        .SetRange Range("D5", Cells(Rows.Count, "E").End(xlUp))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[Mishael]

Станислав большое спасибо. только можно попросить сделать так чтобы (а то я сам недодумаюсь ) сделать чтобы работала не только как в примере на 36 строчек а хотябы строчек на 150, потому чтоданных больше чем в пример.
Еще раз спасибо!!!

[Mishael]

[QUOTE=Mishael;1168596]Станислав большое спасибо. только можно попросить сделать так чтобы (а то я сам недодумаюсь ) сделать чтобы работала не только как в примере на 36 строчек а хотябы строчек на 150, потому чтоданных больше чем в пример.
Еще раз спасибо!!![/QUOT

Так решения и небыло. Может кто сделает попроше.

[Hugo121]

Смотрю код - там нигде нет ограничения на число строк.
Да и куда уже проще

[Казанский]

Это формулой легко делается (для наглядности все на одном листе).

[Mishael]

Спасибо большое испробую