Раз уж сделал, тоже выложу. Если приведете разделитель Марок в ячейке к чему-то одному ('
; '), то сработает для всех ячеек
Код |
---|
Sub PoPuP()
Dim arr(), arrNew(), iTmp
Dim I&, N&
Application.ScreenUpdating = False
With Worksheets("Sheet1")
arr = .Range("B3:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
ReDim arrNew(1 To UBound(arr, 1) * 10, 1 To UBound(arr, 2))
For I = LBound(arr, 1) To UBound(arr, 1)
iTmp = Split(arr(I, 2), ";")
For J = LBound(iTmp) To UBound(iTmp)
N = N + 1
arrNew(N, 1) = arr(I, 1)
arrNew(N, 2) = iTmp(J)
arrNew(N, 3) = arr(I, 3)
Next
Next
Worksheets("Sheet1").Range("I3").Resize(N, 3) = arrNew
Application.ScreenUpdating = True
End Sub
|
А тему не закрою. Теперь уже она не Ваша)