помощь в написании макроса

[frogy]

спасибо, оба работают шикарно и быстро
--------------------------------------------------------------------------------
Добавлено сообщение
--------------------------------------------------------------------------------

В данном случае этого не требуется, т.к. мы формируем массив a, включающий все используемые строки в столбцах "A" и "B", затем определяем массив b той же размерности и в процессе выполнения процедуры, заполняем его. Затем в тот же диапазон, откуда формировали массив a, вставляем массив b, который полностью заменит все значения в этом диапазоне. Если массив b заполнен не полностью, то значения заменятся на пустые.

вопрос вот здесь, чёт не получается, если добавляется столбец С и D как сделать так чтобы он не удалял предыдушую строчку после повторения и данные добавлял именно в столбец С и D а не в B

[frogy]

вот так у меня
Private Sub CommandButton1_Click()
CommandButton1.Enabled = False

Dim i As Long, j As Long, a(), b(), c() As String, x As New Collection
Application.ScreenUpdating = False
With Sheets("Лист2")
a = .Range(.[A2], .Cells(Rows.Count, "d").End(xlUp)).Value
ReDim b(1 To UBound(a, 1), 1 To 4): j = 0
For i = 1 To UBound(a, 1)
On Error Resume Next: x.Add a(i, 1), CStr(a(i, 1))
If Err = 0 Then
j = j + 1: b(j, 1) = a(i, 1): b(j, 2) = a(i, 2): a(i, 2) = NotEmpty: a(i, 3) = Empty: a(i, 4) = Empty
ElseIf a(i, 2) = Empty Then
b(j, 3) = a(i, 3)
ElseIf a(i, 3) = Empty Then
b(j, 4) = a(i, 4)

Else: b(j, 2) = b(j, 2) & "," & a(i, 2): b(j, 3) = b(j, 3) & "," & a(i, 3): b(j, 4) = b(j, 4) & "," & a(i, 4): On Error GoTo 0

End If
Next
.Range(.[A2], .Cells(UBound(b, 1) + 1, UBound(b, 2))).Value = b: .Columns(2).AutoFit
End With
End Sub


но только он нижнюю строчку съедает при повторяющемся первом столбце
что не так.
--------------------------------------------------------------------------------
Добавлено сообщение
--------------------------------------------------------------------------------

Dim i As Long, j As Long, a(), b(), c() As String, x As New Collection
Application.ScreenUpdating = False
With Sheets("Лист2")
a = .Range(.[A2], .Cells(Rows.Count, "d").End(xlUp)).Value
ReDim b(1 To UBound(a, 1), 1 To 4): j = 0
For i = 1 To UBound(a, 1)
On Error Resume Next: x.Add a(i, 1), CStr(a(i, 1))
If Err = 0 Then
j = j + 1: b(j, 1) = a(i, 1): b(j, 2) = a(i, 2): b(j, 3) = a(i, 3): b(j, 4) = a(i, 4)
Else: b(j, 2) = b(j, 2) & ";" & a(i, 2): b(j, 3) = b(j, 3) & ";" & a(i, 3): b(j, 4) = b(j, 4) & ";" & a(i, 4): On Error GoTo 0

End If
Next
.Range(.[A2], .Cells(UBound(b, 1) + 1, UBound(b, 2))).Value = b: .Columns(2).AutoFit
End With

Я победил его но, теперь вставляется ; во всех ячейках с повторением, как победить, точнее почистить ещё на стадии колекции
--------------------------------------------------------------------------------
Добавлено сообщение
--------------------------------------------------------------------------------
ура разобрался всем спасибо