Sub ВПР_с_через_СЛОВАРЬ() 'Очень важно! запуск макроса начинать из файла, куда будем записывать данные
Dim Artikuli() As String
Dim Tablica2 As Range
Dim Artikul As Range
Dim Artikul_column As Long, Artikul2_column As Long, Iskomoe_znachenie_column As Long
Dim Nomer_stolbca As Integer
Dim Nomer_stolbca1 As Range
Dim s As Integer
Dim Artikuli_ As String
Dim tablica As Object
Dim Tablica_ As String
Dim Udalit As String
Dim i_n As Long, i2_n As Long, x As Long, n As String
Dim key As String
Set tablica = CreateObject("Scripting.Dictionary")
Application.EnableEvents = False
'udalit = 0 ' = 1 если надо удалять в артикулах доп символы и необращать на них внимание
' и = 0 если не надо этого делать.
Set Artikul = Application.InputBox("Укажите столбец-Идентификатор в вашей таблице" & Chr(13) & _
"Важно, чтобы макрос был запущен из файла и листа, куда мы будем записывать данные", "Идентификатор", Type:=8)
Set Nomer_stolbca1 = Application.InputBox("Укажите столбец, куда необходимо вывести данные", "Столбец-вывода", Artikul.Worksheet.name & "!A1", Type:=8)
Nomer_stolbca = Nomer_stolbca1.Column
Artikul_column = Artikul.Column
i_n = Cells(Rows.Count, Artikul_column).End(xlUp).Row
Set Tablica2 = Application.InputBox("Укажите столбцы таблицы-исходника", "Таблица-исходник", Type:=8)
Udalit = Application.InputBox("Необходимо ли модифицировать Идентификатор (удалять служебные символы)" _
& Chr(13) & "Оставьте как есть, если надо или измените (на что угодно)", "Удаление Идентификатора", "1")
Iskomoe_znachenie_column = 1
Artikul2_column = 1
For col = 1 To Tablica2.Columns.Count
    If col > Iskomoe_znachenie_column Then
       Iskomoe_znachenie_column = col
    End If
Next col
i2_n = Tablica2.Cells(Tablica2.Rows.Count, Artikul2_column).End(xlUp).Row
ReDim Artikuli(i_n)
Application.ScreenUpdating = False
For i = 1 To i_n
     Artikuli(i) = Artikul.Worksheet.Cells(i, Artikul_column)
Next i
'_________________________________ модуль поиска артикула с удалением части в скобках или после "_" конец
If Udalit = 1 Then
For i = 1 To i_n
     For s = 1 To Len(Artikuli(i))
     If Mid(Artikuli(i), s, 1) Like "[(_]" = True Then
        Exit For
     Else
       Artikuli_ = Artikuli_ & Mid(Artikuli(i), s, 1)
     End If
     Next s
     Artikuli(i) = Artikuli_
     Artikuli_ = ""
Next i
End If
'_________________________________ модуль поиска артикула с удалением части в скобках или после "_" конец
i2_s = IIf(IsEmpty(Tablica2.Cells(1, Artikul2_column)), (Tablica2.Cells(1, Artikul2_column).End(xlDown).Row), 1)
For i2 = i2_s To i2_n
      key = Tablica2.Cells(i2, Artikul2_column)
      If Not tablica.exists(key) Then
         tablica.Add key, Tablica2.Cells(i2, Iskomoe_znachenie_column)
      End If
Next i2
For i = 1 To i_n
      n = 0
      If tablica.exists(Artikuli(i)) Then
        Nomer_stolbca1.Worksheet.Cells(i, Nomer_stolbca) = tablica.Item(Artikuli(i))
      End If
      If Not tablica.exists(Artikuli(i)) Then
       For x = 1 To 4
          If tablica.exists(n & Artikuli(i)) Then: Exit For
          n = n & "0"
       Next x
          Nomer_stolbca1.Worksheet.Cells(i, Nomer_stolbca) = tablica.Item(n & Artikuli(i))
      End If
Next i
Application.ScreenUpdating = True
Artikul.Parent.Parent.Activate
Application.EnableEvents = True
End Sub

Sub Proverka()
Dim A As Range
Dim B As Range

Workbooks("Книга2.xlsm").Activate
Set A = Application.InputBox("A", "A-A", Type:=8)

Workbooks("Книга1.xlsx").Activate
Set B = Application.InputBox("B", "B-B", Type:=8)

MsgBox (A.Parent.Parent.Name) '"Книга2.xlsm"
MsgBox (B.Parent.Parent.Name) '"Книга1.xlsx"

A.Parent.Parent.Activate '"Книга2.xlsm"

End Sub

Sub Proverka2()
Dim A As Range, B As Range

Workbooks("Книга2.xlsm").Activate
Set A = Application.InputBox("A", "A-A", Type:=8)
MsgBox A.Address(, , , True) '[Книга2.xlsm]Лист1!$А$1

Workbooks("Книга1.xlsx").Activate
Set B = Application.InputBox("B", "B-B", Type:=8)
MsgBox B.Address(, , , True) '[Книга1.xlsx]Лист1!$А$1

A.Parent.Parent.Activate '"Книга2.xlsm"
End Sub

Sub Proverka()
     Dim A As Range
     Dim B As Range
     Application.EnableEvents = False
     Set A = Application.InputBox("A", "A-A", Type:=8)
     Set B = Application.InputBox("B", "B-B", Type:=8)
     MsgBox (A.Parent.Parent.name)
     MsgBox (B.Parent.Parent.name)
     A.Parent.Parent.Activate
     Application.EnableEvents = True
End Sub

Sub ВПР_с_через_СЛОВАРЬ() 'Очень важно! запуск макроса начинать из файла, куда будем записывать данные
Dim Artikuli() As String
Dim Tablica2 As Range
Dim Artikul As Range
Dim Artikul_column As Long, Artikul2_column As Long, Iskomoe_znachenie_column As Long
Dim Nomer_stolbca As Integer
Dim Nomer_stolbca1 As Range
Dim s As Integer
Dim Artikuli_ As String
Dim tablica As Object
Dim Tablica_ As String
Dim Udalit As String
Dim i_n As Long, i2_n As Long, x As Long, n As String
Dim key As String
Dim ActWB As Workbook, ash As Worksheet, WB As Workbook
Set ActWB = ActiveWorkbook

'udalit = 0 ' = 1 если надо удалять в артикулах доп символы и необращать на них внимание
' и = 0 если не надо этого делать.
Set Artikul = Application.InputBox("Укажите столбец-Идентификатор в вашей таблице" & Chr(13) & _
"Важно, чтобы макрос был запущен из файла и листа, куда мы будем записывать данные", "Идентификатор", Type:=8)
If Artikul Is Nothing Then Exit Sub
Set ash = Artikul.Worksheet

Set Nomer_stolbca1 = Application.InputBox("Укажите столбец, куда необходимо вывести данные", "Столбец-вывода", Artikul.Offset(0, 1).Address, Type:=8)
Nomer_stolbca = Nomer_stolbca1.Column
Artikul_column = Artikul.Column
i_n = Cells(Rows.Count, Artikul_column).End(xlUp).Row

Set WB = GetAnotherWorkbook
WB.Activate

Set Tablica2 = Application.InputBox("Укажите столбцы таблицы-исходника", "Таблица-исходник", Type:=8)
If Tablica2 Is Nothing Then Exit Sub

ash.Activate
Rows(Artikul.Row).Select
Cells(Artikul.Row, Artikul.Column + 1).Activate

Set tablica = CreateObject("Scripting.Dictionary")
Udalit = Application.InputBox("Необходимо ли модифицировать Идентификатор (удалять служебные символы)" _
& Chr(13) & "Оставьте как есть, если надо или измените (на что угодно)", "Удаление Идентификатора", "1")
Iskomoe_znachenie_column = 1
Artikul2_column = 1
For col = 1 To Tablica2.Columns.Count
If col > Iskomoe_znachenie_column Then
     Iskomoe_znachenie_column = col
End If
Next col
i2_n = Tablica2.Cells(Tablica2.Rows.Count, Artikul2_column).End(xlUp).Row
ReDim Artikuli(i_n)
Application.ScreenUpdating = False
For i = 1 To i_n
     Artikuli(i) = Artikul.Worksheet.Cells(i, Artikul_column)
Next i
'_________________________________ модуль поиска артикула с удалением части в скобках или после "_" конец
If Udalit = 1 Then
For i = 1 To i_n
     For s = 1 To Len(Artikuli(i))
     If Mid(Artikuli(i), s, 1) Like "[(_]" = True Then
     Exit For
     Else
     Artikuli_ = Artikuli_ & Mid(Artikuli(i), s, 1)
     End If
     Next s
     Artikuli(i) = Artikuli_
     Artikuli_ = ""
Next i
End If
'_________________________________ модуль поиска артикула с удалением части в скобках или после "_" конец
i2_s = IIf(IsEmpty(Tablica2.Cells(1, Artikul2_column)), (Tablica2.Cells(1, Artikul2_column).End(xlDown).Row), 1)
For i2 = i2_s To i2_n
     key = Tablica2.Cells(i2, Artikul2_column)
     If Not tablica.Exists(key) Then
         tablica.Add key, Tablica2.Cells(i2, Iskomoe_znachenie_column)
     End If
Next i2
For i = 1 To i_n
     n = 0
     If tablica.Exists(Artikuli(i)) Then
     Nomer_stolbca1.Worksheet.Cells(i, Nomer_stolbca) = tablica.Item(Artikuli(i))
     End If
     If Not tablica.Exists(Artikuli(i)) Then
     For x = 1 To 4
         If tablica.Exists(n & Artikuli(i)) Then: Exit For
         n = n & "0"
     Next x
         Nomer_stolbca1.Worksheet.Cells(i, Nomer_stolbca) = tablica.Item(n & Artikuli(i))
     End If
Next i
Application.ScreenUpdating = True
Application.Windows(ActWB.Name).Activate
End Sub

Private Function GetAnotherWorkbook() As Workbook
     ' если в данный момент открыто 2 книги, функция возвратит вторую открытую книгу
    ' если помимо текущей, открыто более одной книги - будет предоставлен выбор
    On Error Resume Next
     Dim coll As New Collection, WB As Workbook
     For Each WB In Workbooks
         'If WB.Name <> ThisWorkbook.Name Then
             If Windows(WB.Name).Visible Then coll.Add CStr(WB.Name)
        ' End If
     Next WB
     Select Case coll.Count
         Case 0    ' нет других открытых книг
            MsgBox "Нет других открытых книг", vbCritical, "Function GetAnotherWorkbook"
         Case 1    ' открыта ещё только одна книга - её и возвращаем
            Set GetAnotherWorkbook = Workbooks(coll(1))
         Case Else    ' открыто несколько книг - предоставляем выбор
            For i = 1 To coll.Count
                 txt = txt & i & vbTab & coll(i) & vbNewLine
                 If coll(i) = ActiveWorkbook.Name Then n = i
             Next i
             msg = "Выберите одну из открытых книг, и введите её порядковый номер:" & _
                   vbNewLine & vbNewLine & txt
             res = InputBox(msg, "Открыто более двух книг", n)
             If IsNumeric(res) Then Set GetAnotherWorkbook = Workbooks(coll(Val(res)))
     End Select
End Function