[blackeangel]

Я сделал вот так

Скрытый текст

Код:

Sub osnastka()
Application.ScreenUpdating = False
i = 2
' работаем с активной книгой
sWhatFind2 = "Обозначение"
Cells.Find(What:=sWhatFind2, After:=ActiveCell, SearchOrder:=xlByColumns).Activate
ncolumn2 = ActiveCell.Column ' нашли столбец с обозначением
Columns(ncolumn2 + 1).Insert 'вставляем столбец справа
Cells(1, ncolumn2 + 1).Value = "Инструм." 'вставляем заголовок столбца
' работаем с "базой"
sWhatFind = "№ детали"
sWhatFind3 = "Инструм."
n = ThisWorkbook.Path & "" & "оснастка.xlsx"
Set s = GetObject(n)
Set ndetali = s.Worksheets(1).Cells.Find(What:=sWhatFind, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
k = ndetali.Column
Set ninstrum = s.Worksheets(1).Cells.Find(What:=sWhatFind3, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
l = ninstrum.Column
'MsgBox "cell= " & Cells(i, k).Value
'цикл
lLR = s.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Do While ActiveSheet.Cells(i, ncolumn2).Value <> Empty 'поставил на "Обозначение" т.к. обрывался на пустой ячейке
For j = 2 To lLR
If Cells(i, ncolumn2).Value Like s.Worksheets(1).Cells(j, k).Value Then
Cells(i, ncolumn2 + 1).Value = s.Worksheets(1).Cells(j, l).Value
End If
Next j
i = i + 1
Loop
s.Close SaveChanges:=False 'закрываем файл без сохранения
Application.ScreenUpdating = True
End Sub

Но есть огромный недостаток-учитывает только первую входимость, а надо все...
Для перебора 30к позиций хватает...больше уже вешается...
Здесь надо через массивы... Но как хз,я в них ни але
Если что - код, в любом случае, будет в надстройке....
Ах да, и как оказалось, столбцов из базы(2 файл) надо брать 3... И располагаются они хаотично..