将行聚合、整理和转置成列答案

【问题标题】：Aggregate, Collate and Transpose rows into columns将行聚合、整理和转置成列
【发布时间】：2015-06-09 00:36:28
【问题描述】：

我有下表

 Id     Letter
1001    A
1001    H
1001    H
1001    H

1001    B
1001    H
1001    H
1001    H

1001    H
1001    H
1001    H

1001    A
1001    H
1001    H
1001    H
1001    B

1001    A
1001    H
1001    H
1001    H
1001    B

1001    B
1001    H
1001    H
1001    H
1001    B

1001    H

1001    A
1001    G
1001    H
1001    H
1001    A
1001    B

1002    B
1002    H
1002    H
1002    B

1002    G
1002    H

1002    B
1002    G
1002    G
1002    H

1002    B
1002    G
1002    H
1002    H

1002    G
1002    H
1002    H

1002    H
1002    H
1002    H
1002    M
1002    N

1002    G
1002    H
1002    H
1002    M
1002    M

1002    A
1002    H
1002    H
1002    H
1002    A
1002    B

1002    B
1002    H
1002    H
1002    H

1002    B
1002    H
1002    H
1002    H
1002    A
1002    A

1002    A
1002    H
1002    H
1002    H
1002    H
1002    B

1002    H

1003    G
1003    H
1003    H
1003    N
1003    M

我正在尝试转置它以使第一列中的每个不同的 id 和第二列中的所有字母在原始表中的每个空白行都有一个空格：

1001 AHHH BHHH HHH AHHHB AHHHB BHHHB H AGHHAB
1002 BHHB GH BGGH BGHH GHH HHHMN GHHMM AHHHAB BHHH BHHHAA AHHHHB H
1003 GHHNM

我有大约 100 个不同的 id。我尝试使用 TRANSPOSE 和 TRIM 来处理公式。我也尝试过使用宏，VLOOKUP 似乎是最简单的方法，但不知道如何

【问题讨论】：

连接随机长度的值组实际上是不可能的，当然也不切实际。我认为 VBA 是寻求解决方案的唯一现实途径。

标签： arrays excel transpose vba

【解决方案1】：

在事先不知道范围的情况下，您不能使用本机工作表函数连接一系列单元格（又名字母）。由于您将字符串集合到组中具有随机数量的元素，因此 VBA 循环方法似乎是解决该问题的最佳（如果不是唯一）方法。循环可以确定工作表函数根本无法执行的方式。

点击 Alt+F11，当 Visual Basic 编辑器（又名 VBE）打开时，立即使用下拉菜单插入 ► 模块（Alt+I,M）。将以下一项或两项粘贴到标题为 Book1 - Module1 (Code) 的新窗格中。

连接由空格分隔的字符串组：

Sub concatenate_and_transpose_to_delim_string()
    Dim rw As Long, lr As Long, pid As Long, str As String
    Dim bPutInColumns As Boolean

    With ActiveSheet
        lr = .Cells(Rows.Count, 1).End(xlUp).row
        .Cells(1, 4).Resize(1, 2) = Array("Id", "Letters")
        pid = .Cells(2, 1).Value
        For rw = 2 To lr
            If IsEmpty(.Cells(rw, 1)) Then
                str = str & Chr(32)
                If pid <> .Cells(rw + 1, 1).Value Then
                    .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = pid
                    .Cells(Rows.Count, 4).End(xlUp).Offset(0, 1) = str
                End If
            ElseIf pid <> .Cells(rw, 1).Value Then
                pid = .Cells(rw, 1).Value
                str = .Cells(rw, 2).Value
            Else
                str = str & .Cells(rw, 2).Value
            End If
        Next rw
        .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = pid
        .Cells(Rows.Count, 4).End(xlUp).Offset(0, 1) = str
    End With
End Sub

要将字符串组拆分为列：

Sub concatenate_and_transpose_into_columns()
    Dim rw As Long, lr As Long, nr As Long, pid As Long, str As String

    With ActiveSheet
        lr = .Cells(Rows.Count, 1).End(xlUp).row
        .Cells(1, 4).Resize(1, 2) = Array("Id", "Letters")
        For rw = 2 To lr
            If IsEmpty(.Cells(rw, 1)) Then
                .Cells(nr, Columns.Count).End(xlToLeft).Offset(0, 1) = str
                str = vbNullString
            ElseIf pid <> .Cells(rw, 1).Value Then
                pid = .Cells(rw, 1).Value
                nr = .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).row
                .Cells(nr, 4) = pid
                str = .Cells(rw, 2).Value
            Else
                str = str & .Cells(rw, 2).Value
            End If
        Next rw
        .Cells(nr, Columns.Count).End(xlToLeft).Offset(0, 1) = str
    End With
End Sub

点击 Alt+Q 返回您的工作表。使用 A1 中以 Id 开头的活动工作表上的示例数据，点击 Alt+F8 以打开宏对话框和运行宏。

concatenate_and_transpose_to_delim_string 的结果：

concatenate_and_transpose_into_columns 的结果：

结果将从 D2 开始写入单元格。如果事先没有什么重要的东西会被覆盖，这可能是最好的。

附录：

我最初误解了您的请求并将字符串组拆分为单独的列。我已经通过补充例程纠正了这一点，该例程更接近您对需求的描述，但保留了两种变体供其他人参考。

【讨论】：

【解决方案2】：

此选项包含数组。从性能的角度来看，与在工作表中逐个单元格地执行过程相比，将工作表中的数据读取到数组后直接在 VBE 中执行过程并将结果写回工作表要快得多。

Sub transposing()
Const sDestination As String = "D2"
Dim ar1() As Variant
Dim ar2() As Variant
Dim i As Long 'counter

ar1 = ActiveSheet.Range("A2:B" & ActiveSheet.UsedRange.Rows.Count).Value
ReDim ar2(1 To 1, 1 To 2)
ar2(1, 1) = ar1(1, 1): ar2(1, 2) = ar1(1, 2)
For i = 2 To UBound(ar1, 1)
    If ar1(i, 1) = ar2(UBound(ar2, 1), 1) Then
        ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & ar1(i, 2)
    ElseIf ar1(i, 1) = vbNullString Then
        ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & " "
    Else
        ar2 = Application.Transpose(ar2)
        ReDim Preserve ar2(1 To 2, 1 To UBound(ar2, 2) + 1)
        ar2 = Application.Transpose(ar2)
        ar2(UBound(ar2, 1), 1) = ar1(i, 1)
        ar2(UBound(ar2, 1), 2) = ar2(UBound(ar2, 1), 2) & ar1(i, 2)
    End If
Next
ActiveSheet.Range(sDestination).Resize(UBound(ar2, 1), UBound(ar2, 2)).Value = ar2

End Sub

结果将如下所示：

Const sDestination As String = "D2" 行表示输出的开头。将其更改为您想要的任何单元格。

【讨论】：

非常感谢！！两个答案都非常完美，我应该把两者都打勾，并给两者都加分，但不知道如何
谢谢 :) 只是为了通知您未来 - 直接在 VBE 中执行过程比在工作表中循环遍历单元格要快得多。
用户发布了一个新问题，询问您的宏为什么会出现错误 13。当连接的单元格长度为 733 个字符时，它会失败。我的理解是，如果元素的长度为 255 个字符，WorksheetFunction.Transpose 将不起作用。当然，我可以通过将长度减少到 255 来清除错误。请注意，WorksheetFunction.Transpose 是一个慢速函数，ReDim Preserve 会逐渐变慢，所以我认为如果您直接输出到工作表，您将获得一个不会失败的更快例程.
@ZygD - 我试图克服报告的错误，但想看看你对我发布你的子修改的感觉如何。不幸的是，由于没有我知道的“沙盒”，因此无法真正向您展示我的努力，因为没有发布它。
@ZygD 专家一直说Worksheet.Functions 比使用 VBA 编码的相同功能更快。我最近发现这对于我计时的任何功能都不是真的。例如，两个嵌套的 for 循环将创建一个新的转置数组，速度比转置快 3 倍。我很难相信 Excel 函数很慢，所以假设从 VBA 到 Excel 函数的接口开销很大，就像 VB.Net 的接口是 Excel 一样。

【解决方案3】：

对于此类任务，Microsoft 在 Excel 2016 中添加了“Get&Transform”。要在早期版本中使用此功能，您必须使用 Power Query 加载项。 M代码很短：

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    FillIdDown = Table.FillDown(Source,{"Id"}),
    ReplaceNull = Table.ReplaceValue(FillIdDown,null," ",Replacer.ReplaceValue,{"Letter"}),
    Transform = Table.Group(ReplaceNull, {"Id"}, {{"Count", each Text.Combine(_[Letter])}})
in
    Transform

您的数据应位于“Table1”中。 https://www.dropbox.com/s/bnvchofmpvd048v/SO_AggregateCollateAndTransposeColsIntoRows.xlsx?dl=0

【讨论】：