Q
Q
Quip Quip2016-11-02 09:52:00
Visual Basic
Quip Quip, 2016-11-02 09:52:00

How to write macro in vba for excel?

There is an excel sheet with data (approximately in this format
Buyer number. ¦ Order number.
1) 123. ¦ 567
¦ 666
2) 456. ¦ 567
You need to write a vba macro that would display a table in the form:
1) 567. ¦ 123. 456
2) 666. ¦ 123
In general, it is necessary to display the table so that the first cell contains order numbers, and in the cells opposite the customer numbers, and remove repetitions of order numbers. The difficulty is that there are several order numbers in one cell. I unloaded them through a cycle into an array one at a time, now I need to somehow match them with buyers and remove repetitions of order numbers.

Answer the question

In order to leave comments, you need to log in

1 answer(s)
A
Anton Fedoryan, 2016-11-02
@QuipQuip

Preparation:
How to connect RegExp
Using RegExp
Using Dictionary
The macro itself:

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

Result:
3809af86a5e641bea0c431d560e88413.png

Didn't find what you were looking for?

Ask your question

Ask a Question

731 491 924 answers to any question