按关键列将列排序为行（具有随机长度）

Question

快乐的骄傲日！

一个有点棘手的问题，我一直在努力解决。

我正在尝试将三列排序为 3 到 11 个单元格之间的随机长度行，其中 A 列和 B 列本质上是键。

我想要实现的一个简单示例是：

变成：

需要注意的一些关键事项：

• 一行中的最大单元格数应为 11。
• 一行中的单元格数量必须是随机长度，介于 3 到 11 之间，从不超过 11（随机化不是必需的）。
• 第一列 (A) 和第二列 (B) 是键。

以下是我一直在尝试修改以尝试此操作的一些代码，以及一些网站和 Stackoverflow 的人试图实现类似的事情以供参考。

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        Dim columnToMatch As Integer: columnToMatch = 2
        Dim columnToConcatenate As Integer: columnToConcatenate = 1

        lngRow = .Cells(65536, columnToMatch).End(xlUp).Row
        .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes

        Do
            If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then
                .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow - 1, columnToConcatenate) & "; " & .Cells(lngRow, columnToConcatenate)
            .Rows(lngRow).Delete
            End If

            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With
End Sub

参考资料：

• Move Cells into New Row Once Limit is Reached
• Excel tab to new line after certain amount of columns
• Split Excel Column and Copy Data into New Row

Answer 1

我可能会将此作为一个 2 步过程来处理，而不是尝试重新排列工作表。首先将所有数据收集到适当的结构中，然后清除工作表并将结果写回其中。

对于数据收集，收集字典是一个不错的方法，因为它允许您根据两个列键收集数据。由于您不知道需要存储多少值，因此 Collection 是一个很好的容器（尽管 String 数组也可以使用）。数据收集函数看起来像这样：

Private Function GatherData(sheet As Worksheet) As Scripting.Dictionary
    Dim results As New Scripting.Dictionary
    With sheet
        Dim key As String
        Dim currentRow As Long
        For currentRow = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
            key = .Cells(currentRow, 1) & "|" & .Cells(currentRow, 2)
            If Not results.Exists(key) Then results.Add key, New Collection
            results(key).Add .Cells(currentRow, 3).Value
        Next currentRow
    End With
    Set GatherData = results
End Function

您需要添加对 Microsoft Scripting Runtime 的引用。另请注意，这不需要对输入进行排序。

一旦你有了数据，写出来就相当容易了。只需遍历键并根据您需要的任何参数编写集合：

Private Sub WriteResults(sheet As Worksheet, data As Scripting.Dictionary)
    Dim currentRow As Long
    Dim currentCol As Long
    Dim index As Long
    Dim key As Variant
    Dim id() As String
    Dim values As Collection

    currentRow = 2
    For Each key In data.Keys
        id = Split(key, "|")
        Set values = data(key)
        currentCol = 3
        With sheet
            .Cells(currentRow, 1) = id(0)
            .Cells(currentRow, 2) = id(1)
            For index = 1 To values.Count
                .Cells(currentRow, currentCol) = values(index)
                currentCol = currentCol + 1
                If currentCol > 11 And index < values.Count Then
                    currentRow = currentRow + 1
                    currentCol = 3
                    .Cells(currentRow, 1) = id(0)
                    .Cells(currentRow, 2) = id(1)
                End If
            Next index
            currentRow = currentRow + 1
        End With
    Next key
End Sub

请注意，这不会随机化名称集合或每行中的数字（如果有超过 9 个），但将内部循环提取到另一个 Sub 来执行此操作相当容易。

像这样把它们放在一起：

Sub mergeCategoryValues()
    Dim target As Worksheet
    Dim data As Scripting.Dictionary

    Set target = ActiveSheet
    Set data = GatherData(target)
    target.UsedRange.ClearContents
    WriteResults target, data
End Sub