Question

需要VBA宏将数据合并为4列。试图进行合并，但无法正常工作。

请查看图片以获得更好的理解。红色箭头说明了我的需要。

我需要一个有效的VBA，才能从左侧的4列转到右侧的4列：在合并b列中的值和d列中的值的同时，按a和c列合并数据（从第2行向下的所有行）。

下面的代码不起作用，并且缺少部分内容。

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

由于范围始终相同，可以删除“设置InputRng = Application.Selection和设置InputRng = Application.InputBox”。

Answer 1

我使用了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

或者只是偷懒地做，创建一个数据透视表并使用公式来连接字符串：

Answer 2

输出转到F:I列中的同一工作表。 Workbook with code。

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

在几列中汇总，连接和合并数据

2 个答案: