Как написать макрос на vba для excel?

Question

[Quip Quip]

Есть лист excel с данными(примерно в таком формате
Номер покупателя. ¦ Номер заказа.
1) 123. ¦ 567
¦ 666
2) 456. ¦ 567

Надо написать макрос на vba который вывел бы таблицу в виде:
1) 567. ¦ 123. 456
2) 666. ¦ 123

В общем, надо вывести таблицу так, что бы в первой ячейке были номера заказов, а в ячейках напротив номера покупателей и убрать повторения номеров заказа. Трудность в том, что в одной ячейке несеолько номеров заказов. Я их через цикл выгрузил в массив по одному, теперь надо как то сопоставить им покупателей и убрать повторения номеров заказов.

Answer 1

[Антон Федорян]

Подготовка:

Как подключить RegExp
Использование RegExp
Использование Dictionary

Сам макрос:

Sub order()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim objRegExp As New RegExp
    Dim pattern As String
    Dim Dict As New Dictionary
    Dim ResRow As Integer
    Dim NumOrder As Integer
    
    
    Set WB = Excel.ActiveWorkbook
    Set WS = WB.ActiveSheet
    
    ' Ищем только цифры
    pattern = "\d+"
    
    With objRegExp
        .Global = True
        .IgnoreCase = True
        .pattern = pattern
        .MultiLine = True
    End With
    
    ' Номер строки, с которой начинается запись результатов
    ResRow = 10
    ' Проходим со 2 по 5 строки с заказами
    For r = 2 To 5
        ' 2 - столбец с номерами заказов
        Set objMatches = objRegExp.Execute(WS.Cells(r, 2))
        For i = 0 To objMatches.Count - 1
            Set objMatch = objMatches.Item(i)
            NumOrder = objMatch.Value
            
            ' Если номер заказа раньше не встречался
            If Not Dict.Exists(NumOrder) Then
                Dict.Add NumOrder, ResRow
                ' Пишем в 1 столбец номер заказа
                WS.Cells(ResRow, 1) = NumOrder
                ResRow = ResRow + 1
            End If
            
            ' Выписываем номера покупателей
            If IsEmpty(WS.Cells(Dict.Item(NumOrder), 2)) Then
                WS.Cells(Dict.Item(NumOrder), 2) = WS.Cells(r, 1)
            Else
                WS.Cells(Dict.Item(NumOrder), 2) = WS.Cells(Dict.Item(NumOrder), 2) & ", " & WS.Cells(r, 1)
            End If
        Next i
    Next r
    
    Set objRegExp = Nothing
End Sub

Результат:

Comments

[Quip Quip]

Спасибо большое, а как составить патерн, что бы он и цифры и символы искал в количестве 6 штук и игнорировал точку с запятой и символ пробелы ?
"/w+/W+"?

[Quip Quip]

Все, разобрался с патерном, только он в разые ячейки не выводит, а все пихает в одну.