Помогите написать макрос. Нужно из вкладки СА перенести все совпадения (столбцы E, D) по столбцу B во вкладку "упр(2)" со столбцом D (без последних трех символов) . Бывает по несколько совпадений. Во вкладке "упр(2)" в столбцах E и F как в итоге должно получиться.
Kuzmich, в файле нет макроса, т.к. на разных компьютерах делался файл и разные офисы на компах, поэтому просто в ставила в текст. А я вроде и не указываю столбец А, где вы увидели? Насчет цикла точно не могу ответить, этот макрос мне тут подсказали, только для другого документа. Я попыталась переделать, но не получается.
Sub Articul()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim Articul As String
Dim FAdr As String
Dim n As Integer
iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
Range("E5:G" & iLastRow).ClearContents
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 5
For i = 5 To iLastRow
If Not IsEmpty(Cells(i, "D")) Then
Articul = Left(Cells(i, "D"), Len(Cells(i, "D")) - 3)
If Not .exists(Articul) Then
.Add Articul, 1
Cells(n, 5) = Articul
n = n + 1
End If
End If
Next
End With
With Worksheets("СА")
iLastRow = Cells(Rows.Count, "E").End(xlUp).Row
n = 0
For i = 5 To iLastRow
Articul = Cells(i, "E")
Set FoundCell = .Columns(2).Find(Articul, , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
Do
.Range(.Cells(FoundCell.Row, "E"), .Cells(FoundCell.Row, "F")).Copy Cells(i + n, "F")
Set FoundCell = .Columns(2).Find(Articul, after:=FoundCell)
n = n + 1
Loop While FoundCell.Address <> FAdr
End If
Next
End With
End Sub
Kuzmich, да все правильно срабатывает, только при сопоставлении по третьему усеченному артикулу, строчки съехали на одну ниже,и напротив первой позиции (по третьему усеченному артик.) пусто.