i = 1
    For Each cl In Selection.SpecialCells(xlCellTypeVisible)
        ReDim Preserve arrV(i)
        arrV(i) = CStr(cl.Value)
        If arrV(i) <> "" Then i = i + 1 'пропуск пустых ячееек
    Next

Option Explicit

Sub compare()
    Dim a, b, c, iLastrow As Long, i As Long, ii As Long

    '1. данные в два массива
    With Sheet1    'используется кодовое имя
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        a = Range(.[a3], .Range("A" & iLastrow)).Value
    End With

    With Sheet2    'используется кодовое имя
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        b = Range(.[c2], .Range("A" & iLastrow)).Value
    End With

    '2.пустой массив для результата
    ReDim c(1 To UBound(a), 1 To 2)

    With CreateObject("Scripting.Dictionary")
    
        '3.в словарь уникальные и номер строки из массива
        For i = 1 To UBound(b)
            .Item(b(i, 1)) = i
        Next

        '4.по словарю из массива b в массив c
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then
                c(i, 1) = b(.Item(a(i, 1)), 2)
                c(i, 2) = b(.Item(a(i, 1)), 3)
            End If
        Next
    End With

    '5. выгрузка всего массива
    With Sheet1    'используется кодовое имя
        .[B3].Resize(UBound(c), 2) = c
        .Activate
    End With
End Sub

NumberLastRow = Cells(Rows.Count, 13).End(xlUp).Row
art = Range("C1:J" & NumberLastRow).Value

Sub Тест()
    Dim Index1
    On Error Resume Next
    Set Index1 = Application.InputBox("Индекс:", "Запрос данных", Selection.Address, Type:=8)
    If Index1 Is Nothing Then 'нажата кнопка Отмена - диапазон не выбран
        MsgBox "Отмена выполнения", vbCritical, "Нет данных"
        Exit Sub
    End If
    LrOW1 = Cells(Rows.Count, Index1.Column).End(xlUp).Row
    MsgBox LrOW1
End Sub

Sub Наименьший_и_счет()
'

    Dim NumberLastRow, LastColumn, i, j, s As Long
    NumberLastRow = Range("a1").CurrentRegion.Rows.Count ' последняя строка
    LastColumn = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' последний столбец
    a = NumberLastRow - 1
    Dim IndexA
    Dim IndexD
    Dim IndexR
    ReDim IndexR(a)
    IndexA = Range(Cells(2, 1), Cells(NumberLastRow, 1))
    IndexD = Range(Cells(2, 2), Cells(NumberLastRow, 2))
    For j = 1 To a
    s = 0
    IndexA1 = IndexA(j, 1)
    IndexD1 = IndexD(j, 1)
        For i = 1 To a
            If IndexA(i, 1) = IndexA1 Then
            s = s + 1
                If IndexD(i, 1) < IndexD1 Then IndexD1 = IndexD(i, 1)
            End If
        Next i
    IndexR(j) = IndexD1
    Cells(j + 1, 3) = IndexD1
    Cells(j + 1, 4) = s
    Next j
    Range("f2:f10") = IndexR
End Sub

Sub ПОИСПОЗ()
'
' Макрос1 Макрос
'
    Dim vRetVal
     
    On Error Resume Next
    Set vRetVal = Application.InputBox("Укажите диапазон заполнения:", "Запрос данных", Selection.Address, Type:=8)
    If vRetVal Is Nothing Then 'нажата кнопка Отмена - диапазон не выбран
        MsgBox "Отмена выполнения", vbCritical, "Нет данных"
        Exit Sub
    End If
    Dim vRetVal1 'для получения выбранного значения
 
    On Error Resume Next
    Set vRetVal1 = Application.InputBox("Что сравнивается:", "Запрос данных", Selection.Address, Type:=8)
    If vRetVal1 Is Nothing Then 'нажата кнопка Отмена - диапазон не выбран
        MsgBox "Отмена выполнения", vbCritical, "Нет данных"
        Exit Sub
    End If
    Dim vRetVal2 'для получения выбранного значения
 
    On Error Resume Next
    Set vRetVal2 = Application.InputBox("C чем сравнить:", "Запрос данных", Selection.Address, Type:=8)
    If vRetVal2 Is Nothing Then 'нажата кнопка Отмена - диапазон не выбран
        MsgBox "Отмена выполнения", vbCritical, "Нет данных"
        Exit Sub
    End If
 
    vRetVal.Select
    Selection.FormulaR1C1 = "=MATCH(" & vRetVal1 & "," & vRetVal2 & ",0)"
 
End Sub