将行聚合,整理和转置为列

时间:2015-04-03 22:09:09

标签: arrays excel excel-vba transpose vba

我有下表

 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个不同的身份证。我尝试使用TRANSPOSE和TRIM进行配方。我也试过一个宏,VLOOKUP似乎是最简单的方法,但无法找到如何

3 个答案:

答案 0 :(得分:6)

在事先不知道范围的情况下,您无法使用本机工作表函数连接一系列单元格(也称为 Letters )。由于您的字符串集合具有随机数量的元素,因此VBA循环方法似乎是解决该问题的最佳方法(如果不是唯一的方法)。循环可以在工作表函数根本无法执行的过程中进行确定。

点击 Alt + F11 ,当Visual Basic编辑器(又名VBE)打开时,立即使用下拉菜单插入►模块( Alt < / KBD> + 中号)。将以下一项或两项粘贴到标题为 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 打开对话框并< strong>运行宏。

来自concatenate_and_transpose_to_delim_string的结果:

Concatenate and Transpose to delim strang

来自concatenate_and_transpose_into_columns的结果:

Concatenate and Transpose

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

<强>附录:

我原来错误解释了您的请求,并将字符串组拆分为单独的列。我已经用补充程序纠正了这个问题,这个程序更贴切地遵循您对要求的描述,但保留了其他参考文献的变化。

答案 1 :(得分:4)

此选项包含数组。从性能的角度来看,一旦将工作表中的数据读取到数组,直接在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

结果如下所示: enter image description here

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

答案 2 :(得分:0)

对于此类任务,Microsoft将“Get&amp; Transform”添加到Excel 2016.为了在早期版本中使用此功能,您必须使用Power Query Add-In。 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

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