Суммируйте, объединяйте и объединяйте данные в несколько столбцов

Question

Нужен макрос VBA для объединения данных в 4 столбца.Пытался объединить, но это не сработало.

Пожалуйста, посмотрите на картинку для лучшего понимания.Красная стрелка объясняет, что мне нужно.

Мне нужен рабочий VBA, чтобы перейти от 4 столбцов слева к 4 столбцам справа: объединить данные (все строки из строки № 2 вниз) по столбцамa & c при консолидации значений в столбце b и объединении значений в столбце d.

Этот код ниже не работает и отсутствуют детали.

Sub CombineRows()
'This section combines and sum A and B but not C (1 to 6) and D and 
'deletes rows that should not delete instead, because of the second 
'part of the code
  Dim Rng As Range
  Dim InputRng As Range
  Dim nRng As Range
   Set InputRng = Application.Selection
   Set InputRng = Application.InputBox("Range :", xTitleId, 
     InputRng.Address, Type:=8)
   Set InputRng = InputRng.Parent.Range(InputRng.Columns(1).Address)
     With CreateObject("scripting.dictionary")
     .CompareMode = vbTextCompare
   For Each Rng In InputRng
If Not .Exists(Rng.Value) Then
.Add Rng.Value, Rng.Offset(, 1)
   Else
.Item(Rng.Value).Value = .Item(Rng.Value).Value + Rng.Offset(, 1)
    If nRng Is Nothing Then
        Set nRng = Rng
    Else
        Set nRng = Union(nRng, Rng)
    End If
Next
    If Not nRng Is Nothing Then
    nRng.EntireRow.Delete
Next

'Second Part To combine A and D but it's not combining (maybe because 
'of the large amount of data and I also need the comma between values 
'in column D, not space but it doesn't work - deletes data
  Dim WorkRng As Range
  Dim Dic As Variant
  Dim arr As Variant
    On Error Resume Next
    xTitleId = "Combine"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, 
      WorkRng.Address, Type:=8)
    Set Dic = CreateObject("Scripting.Dictionary")
      arr = WorkRng.Value   
    For i = 1 To UBound(arr, 1)
      xvalue = arr(i, 1)
    If Dic.Exists(xvalue) Then
      Dic(arr(i, 1)) = Dic(arr(i, 1)) & " " & arr(i, 2)
    Else
      Dic(arr(i, 1)) = arr(i, 2)
    End If
 Next
    Application.ScreenUpdating = False
      WorkRng.ClearContents
      WorkRng.Range("A1").Resize(Dic.Count, 1) = 
    Application.WorksheetFunction.Transpose(Dic.keys)
      WorkRng.Range("D1").Resize(Dic.Count, 1) = 
    Application.WorksheetFunction.Transpose(Dic.items)
    Application.ScreenUpdating = True
  End Sub

"Set InputRng = Application.Selectionи Set InputRng = Application.InputBox "можно удалить, так как диапазон всегда одинаков.

Answer 1

Вывод на тот же лист в столбцах F:I. Рабочая тетрадь с кодом .

Sub DoConsolidation()
    Dim x, r, z, field_a, field_c, vsum, id, dic, k
    r = 2: z = 1: Set dic = CreateObject("Scripting.Dictionary")
    '// To make code work, we need to sort data
    Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Key2:=Range("C1"), Header:=xlYes
    While Len(Cells(r, 1)) > 0
        field_a = Cells(r, "A"): field_c = Cells(r, "C")
        x = r: z = z + 1: vsum = 0: id = "": dic.RemoveAll
        Cells(z, "F") = field_a: Cells(z, "H") = field_c
        While (Cells(x, "A") = field_a) And (Cells(x, "C") = field_c)
            k = Cells(x, "D").Value: dic(k) = k
            vsum = vsum + Cells(x, "B")
            x = x + 1
        Wend
        For Each k In dic.Keys(): id = id & k & ",": Next
        Cells(z, "G") = vsum: Cells(z, "I") = Left(id, Len(id) - 1)
        r = x
    Wend
    MsgBox "Well done!", vbInformation
End Sub

Answer 2

Я выбрал другое решение, используя смесь VBA и формул.Я думаю, что это немного более читабельно и, конечно, короче.Может быть, это не пуристская идея кода VBA, но именно так мне нравится делать вещи.Код предполагает, что входная таблица находится в столбцах A: D, а выходные данные будут в столбцах E: I - это, конечно, можно изменить.

Sub unique()
     Dim arr As New Collection, a
     Dim tmp() As Variant, var() As Variant
     Dim i As Long, j As Long, iRowCount As Long, iNewRowCount As Long
     Dim str As String
     Dim rng As Range

    iRowCount = Cells(Rows.Count, "A").End(xlUp).Row

    Set rng = Range("A2:C" & iRowCount)

     ' Columns 1 & 3 - create unique list
      tmp = rng
      For i = 1 To UBound(tmp, 1)
         ReDim Preserve var(i)
         var(i) = CStr(tmp(i, 1) & tmp(i, 3))
      Next

     On Error Resume Next
     For Each a In var
        arr.Add a, a
     Next
     On Error GoTo 0

      For i = 2 To arr.Count + 1
        Cells(i, 6) = Left(arr(i - 1), Len(arr(i - 1)) - 1)
        Cells(i, 8) = Right(arr(i - 1), 1)
     Next

     iNewRowCount = Cells(Rows.Count, "F").End(xlUp).Row

    ' Column 2 - sum based on columns 1 & 3
     Range("G2") = "=SUMIFS($B$2:$B$" & iRowCount & ",$A$2:$A$" & iRowCount & ",""=""&F2,$C$2:$C$" & iRowCount & ",""=""&H2)"
     Range("G2:G" & iNewRowCount).FillDown


     'Column 4 concatenate with comma
    For i = 2 To iNewRowCount
        For j = 2 To iRowCount
            If Cells(j, 1) & Cells(j, 3) = Cells(i, 6) & Cells(i, 8) Then
                str = str & Cells(j, 4) & ","
            End If
        Next
        Cells(i, 9) = Left(str, Len(str) - 1)
        str = ""
    Next


End Sub

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