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
open(), а затем запросы, можно несколько разных БД пробовать, это облегчит общее понимание.