Excel：根据ID合并列中的内容

Question

我正在尝试合并具有相同 ID 的行。我已经让它工作了，但是合并的顺序没有得到尊重。它将相同 ID 的最后一个值放在首位，而不是尊重行顺序。有谁知道如何实现这一目标？

输入：

ID	Value
101
101	325grams
101	500grams
100
100	200 grams
100	1 kilo
100	3 kilo

现状：

ID	Value
101	500 grams, 325grams
100	3 kilo, 200 grams, 1 kilo

所需的解决方案：

ID	Value
101	325 grams, 500 grams
100	200 grams, 1 kilo, 3 kilo

代码：

Sub Consolidate_Rows()
    
    Dim xRg         As Range
    Dim xRows       As Long
    Dim i           As Long, J As Long, K As Long
    
    On Error Resume Next
    Set xRg = Application.InputBox("Select Range:", "Consolidate selection", Selection.Address, , , , , 8)
    Set xRg = Range(Intersect(xRg, ActiveSheet.UsedRange).Address)
    
    If xRg Is Nothing Then Exit Sub
    xRows = xRg.Rows.Count
    For i = xRows To 2 Step -1
        For J = 1 To i - 1
            If xRg(i, 1).Value = xRg(J, 1).Value And J <> i Then
                For K = 2 To xRg.Columns.Count
                    If xRg(J, K).Value <> "" Then
                        If xRg(i, K).Value = "" Then
                            xRg(i, K) = xRg(J, K).Value
                        Else
                            xRg(i, K) = xRg(i, K).Value & "," & xRg(J, K).Value
                        End If
                    End If
                Next
                xRg(J, 1).EntireRow.Delete
                i = i - 1
                J = J - 1
            End If
        Next
    Next
    ActiveSheet.UsedRange.Columns.AutoFit
End Sub

非常感谢！

编辑： 更改表格以更类似于我的数据。合并单元格的排序应不按字母顺序排列，而应按行顺序排列。

Answer 1

几点说明：

1. 您可以使用集合来检查输入范围，而不是使用 OERN

2. 您还可以利用字典并添加 ID 和值，然后输出到范围

---

一些建议：

• 将变量命名为有意义的名称（我很难理解，反之更容易）
• 正确缩进你的代码（你可以使用Rubberduckvba.com）来帮助你处理数据
• 尝试将你的代码分解成小块（例如先将数据存入一个数组，然后检查concat，清除范围后，最后输出）
• 评论您的代码

---

阅读代码的 cmets 并根据您的需要进行调整

Public Sub ConsolidateRows()
    
    ' Get user range input | Credits: https://stackoverflow.com/a/37545423/1521579
    Dim rangeCollection As Collection
    Set rangeCollection = New Collection
    rangeCollection.Add Application.InputBox(Prompt:="Select Range:", Title:="Consolidate selection", Default:=Selection.Address, Type:=8)
    
    Dim sourceRange As Range
    If TypeOf rangeCollection(1) Is Range Then Set sourceRange = rangeCollection(1)
    
    ' Exit if no selection was mage
    If sourceRange Is Nothing Then Exit Sub
    
    ' Read range into array
    Dim sourceArray As Variant
    sourceArray = sourceRange.Value
    
    ' Create a dictionary to store IDs and Values
    Dim targetDict As Object
    Set targetDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through each row
    Dim rowCounter As Long
    For rowCounter = 1 To UBound(sourceArray)
        
        Select Case True
        ' Handle first row
        Case rowCounter = 1
            targetDict.Add Key:=CStr(sourceArray(rowCounter, 1)), Item:=sourceArray(rowCounter, 2)
        ' If ID is equal to previous concat with previous
        Case CStr(sourceArray(rowCounter, 1)) = CStr(sourceArray(rowCounter - 1, 1))
        ' If ID is not equal to previous add new item to dictionary
            targetDict(CStr(sourceArray(rowCounter, 1))) = targetDict(CStr(sourceArray(rowCounter, 1))) & "," & sourceArray(rowCounter, 2)
        Case Else
            targetDict.Add Key:=CStr(sourceArray(rowCounter, 1)), Item:=sourceArray(rowCounter, 2)
        End Select
        
    Next rowCounter
    
    ' Clear source range values
    sourceRange.Clear
    
    ' Output dictionary to the first cell in source range
    Dim targetRange As Range
    Set targetRange = sourceRange.Cells(1, 1)
    
    targetRange.Resize(targetDict.Count, 1).Value = Application.WorksheetFunction.Transpose(targetDict.keys)
    targetRange.Offset(0, 1).Resize(targetDict.Count, 1).Value = Application.WorksheetFunction.Transpose(targetDict.items)
    
    
End Sub

---

让我知道它是否有效

Answer 2

您也可以使用 Excel 2010+ 中提供的 Power Query 来执行此操作

• 在数据表中选择一个单元格
• Data => Get&Transform => from Table/Range
• 在 PQ 中，Home => Advanced Editor
  • 记下第 2 行中的表名
  • 用上面的 MCode 替换现有代码
  • 更改第 2 行中的表名以反映您的实际表名。
• 表是Grouped，由ID
  • 排序和连接由List.Accumulate 和List.Sort 函数完成。

M 码

let
    Source = Excel.CurrentWorkbook(){[Name="Table2"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"ID", Int64.Type}, {"Value", type text}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"ID"}, {{"Grouped", each List.Accumulate(
           List.Sort([Value]), 
        "", (state, current)=> if state = "" then current else state & ", " & current), type text}})
in
    #"Grouped Rows"

Answer 3

我在另一个 SO 帖子上为您找到了解决方案。

excel: how do i sort within a cell?

您的整个代码现在应该如下所示。

Sub Consolidate_Rows()
    
    Dim xRg         As Range
    Dim xRows       As Long
    Dim i           As Long, j As Long, K As Long
    
    On Error Resume Next
    Set xRg = Application.InputBox("Select Range:", "Consolidate selection", Selection.Address, , , , , 8)
    Set xRg = Range(Intersect(xRg, ActiveSheet.UsedRange).Address)
    
    If xRg Is Nothing Then Exit Sub
    xRows = xRg.Rows.Count
    For i = xRows To 2 Step -1
        For j = 1 To i - 1
            If xRg(i, 1).Value = xRg(j, 1).Value And j <> i Then
                For K = 2 To xRg.Columns.Count
                    If xRg(j, K).Value <> "" Then
                        If xRg(i, K).Value = "" Then
                            xRg(i, K) = xRg(j, K).Value
                        Else
                            xRg(i, K) = xRg(i, K).Value & "," & xRg(j, K).Value
                        End If
                    End If
                Next
                xRg(j, 1).EntireRow.Delete
                i = i - 1
                j = j - 1
            End If
        Next
    Next
    ActiveSheet.UsedRange.Columns.AutoFit
Call HSort
End Sub

Sub HSort()

Dim rng As Range, cell As Range
Dim i As Integer
Dim arr As Variant
Set rng = Range("B2:B3")
For Each cell In rng

    cell.Select
    arr = Split(ActiveCell.Text, ",")

    ' trim values so sort will work properly
    For i = LBound(arr) To UBound(arr)
        arr(i) = Trim(arr(i))
    Next i

    ' sort
    QuickSort arr, LBound(arr), UBound(arr)

    ' load sorted values back to cell
    Dim comma As String
    comma = ""
    ActiveCell = ""
    For i = LBound(arr) To UBound(arr)
        ActiveCell = ActiveCell & comma & CStr(arr(i))
        comma = ","
    Next i
    
Next cell

End Sub

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

Dim pivot   As Variant
Dim tmpSwap As Variant
Dim tmpLow  As Long
Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)

     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If

  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

End Sub

之前：

之后：

Answer 4

这个建议的解决方案：

• 使用Filter function 确保提取的值保持范围行顺序。
• 使用字典来保存唯一 ID 及其所有对应值。

使用所使用的方法，无需多次循环数据。

Sub Consolidate_IDs_And_Values()
Const kTitle As String = "Consolidate selection"
Const kFml As String = "Transpose(""|""&#ID&""|""&#VAL)"
Dim Rng As Range, sMsg As String, sFml As String
Dim Dtn As Object
Dim aIds As Variant, aValues As Variant, aFilter As Variant
Dim vKey As Variant, sKey As String, L As Long

    Rem Set Input Range from User
    On Error Resume Next
    Set Rng = Application.InputBox( _
        "Select Range (excluding header and at least two columns):", _
        kTitle, Selection.Address, Type:=8)
    On Error GoTo 0
    
    Rem Validate Input Range
    If Rng Is Nothing Then
        MsgBox "Input box was cancelled.", , kTitle
        Exit Sub
    End If
    If Rng.Columns.Count < 2 Then
        MsgBox "Input range must have at least two columns.", , kTitle
        Exit Sub
    End If
    
    Rem Set IDs and Values Arrays
    With Rng
        aIds = Application.Transpose(.Columns(1).Value)
        sFml = Replace(Replace(kFml, "#ID", .Columns(1).Address), "#VAL", .Columns(2).Address)
        aValues = Application.Evaluate(sFml)
    End With
    
    Rem Set Dictionary
    Set Dtn = CreateObject("Scripting.Dictionary")
    
    Rem Add Unique ID's with all corresponding Values to Dictionary
    With Dtn
        For Each vKey In aIds
            If Not (.Exists(vKey)) Then
                
                Rem Filter Key Values
                sKey = "|" & vKey & "|"
                aFilter = Filter(aValues, sKey, True)
                aFilter = Join(aFilter, ", ")
                aFilter = Replace(aFilter, sKey & ", ", "")   'EDIT: this line is added to eliminate the Items with [Value]=empty
                aFilter = Replace(aFilter, sKey, "")

                Rem Filter Key & Values to Dictionary
                Dtn.Add vKey, aFilter
        
        End If: Next
        
        L = .Count
    
    End With
    
    With Rng
            
        Rem Delete Remaining Rows
        .Rows(1).Offset(L).Resize(.Rows.Count - L).EntireRow.Delete
        
        Rem Post Dictionary
        .Cells(1, 1).Resize(L).Value = Application.Transpose(Dtn.Keys)
        .Cells(1, 2).Resize(L).Value = Application.Transpose(Dtn.Items)
        
        .Columns.AutoFit

    End With

    End Sub

之前：

之后：