Макрос Excel - строки с разделенными запятыми ячейками (столбец сохранения / агрегирования)

Question

На основании этих данных:

    <- A (Category) ->   <- B (Items) -> 
1   Cat1                 a
2   Cat1                 b
3   Cat1                 c
4   Cat2                 d
5   Cat3                 e
6   Cat4                 f
7   Cat4                 g

Мне нужно это:

    <- A (Category) ->   <- B (Items) -> 
1   Cat1                 a,b, c
2   Cat2                 d
3   Cat3                 e
4   Cat4                 f, g

Answer 1

Если вы хотите сохранить свои исходные данные и просто суммировать данные где-то еще, вы можете использовать следующий метод:

Создайте пользовательскую функцию в VB, которая по сути аналогична CONCATENATE, но может бытьиспользуется в формуле массива.Это позволит вам вставить оператор IF для переменной диапазона в функции CONCATENATE.Вот быстрая версия, которую я набросал:

Private Function CCARRAY(rr As Variant, sep As String)
'rr is the range or array of values you want to concatenate.  sep is the delimiter.
Dim rra() As Variant
Dim out As String
Dim i As Integer

On Error GoTo EH
rra = rr

out = ""
i = 1

Do While i <= UBound(rra, 1)
    If rra(i, 1) <> False Then
        out = out & rra(i, 1) & sep
    End If
    i = i + 1
Loop
out = Left(out, Len(out) - Len(sep))

CCARRAY = out
Exit Function

EH:
rra = rr.Value
Resume Next

End Function

Таким образом, вы можете использовать следующее в этой таблице для суммирования элементов:

{=CCARRAY(IF(A1:A7="Cat1",B1:B7),", ")}

Не забудьте нажимать Ctrl + Shift + Enter при вводеформула.

Answer 2

Вы можете попробовать это:

Sub GroupMyValues()

    Dim oCell As Excel.Range
    Dim sKey As String
    Dim sResult As String

    Set oCell = Worksheets(2).Range("A1")

    While Len(oCell.Value) > 0

        If oCell.Value <> sKey Then

            'If first entry, no rows to be deleted
            If sKey <> "" Then

                oCell.Offset(-1, 1).Value = sResult

            End If

            sKey = oCell.Value
            sResult = oCell.Offset(0, 1).Value
            Set oCell = oCell.Offset(1, 0)

        Else

            sResult = sResult & ", " & oCell.Offset(0, 1).Value

            Set oCell = oCell.Offset(1, 0)
            oCell.Offset(-1, 0).EntireRow.Delete

        End If

    Wend

    'Last iteration
    oCell.Offset(-1, 1).Value = sResult

End Sub