[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
'цикл
Do While Cells(i, ncolumn2).Value <> Empty 'поставил на "Обозначение" т.к. обрывался на пустой ячейке
If Cells(i, k).Value Like Cells(i, ncolumn2).Value Then
Cells(i, ncolumn2 + 1).Value = s.Worksheets(1).Cells(i.Row, l)
End If
i = i + 1
Loop
s.Close SaveChanges:=False 'закрываем файл без сохранения
End Sub

Если есть вариант через массивы сделать то буду рад