vba 将包含不同数据但具有共同引用的多行“展平”到单行中

"Flatten" multiple rows containing different data but with a common reference into a single row

提问by user2548029

I've tried searching Stackoverflow and Google for an answer to this but haven't found it yet. I think part of my problem is I'm not sure what the keyword(s) for what I'm trying to do would be.

我试过在 Stackoverflow 和 Google 上搜索这个问题的答案，但还没有找到。我认为我的问题的一部分是我不确定我正在尝试做的关键字是什么。

My data looks something like this:

我的数据看起来像这样：

ID    Var1    Var2    Name
01    0001    0002    Bill
01    0001    0002    Jim
01    0001    0002    Sally
02    0003    0004    Sam
02    0003    0004    Kyle

You'll see that I have multiple rows with the same ID and same Var1 and Var2 but each row has a unique name. I want to "flatten" the rows so there is only a single row for each ID and each row has as many "Name" columns as are necessary to fit all of the data.

您会看到我有多行具有相同的 ID 和相同的 Var1 和 Var2，但每一行都有一个唯一的名称。我想“展平”行，因此每个 ID 只有一行，并且每行都有尽可能多的“名称”列，以适应所有数据。

Like this:

像这样：

ID    Var1    Var2    Name1    Name2    Name3
01    0001    0002    Bill     Jim      Sally
02    0003    0004    Sam      Kyle

Does anyone know how to do this or what it's called?

有谁知道如何做到这一点或它叫什么？

Thanks!

谢谢！

Update based on comments: My data source is .csv file and I'm trying to manipulate it with Excel. Excel macros or VBA solutions would be best. Unfortunately my SQL is very elementary so learning to apply an SQL solution would be time-prohibitive.

根据评论更新：我的数据源是 .csv 文件，我正在尝试使用 Excel 对其进行操作。Excel 宏或 VBA 解决方案是最好的。不幸的是，我的 SQL 是非常初级的，所以学习应用 SQL 解决方案需要时间。

采纳答案by brettdj

Something like this is very quick using variant arrays and a dictionary object

使用变体数组和字典对象，这样的事情非常快

The code dumps the output from A1:Dxto F1

代码将输出转储A1:Dx到F1

Update: fixed name numerals

更新：固定名称数字

Sub ReCut()
Dim X
Dim Y
Dim C

Dim lngRow As Long
Dim lngCol As Collection
Dim lngCnt1 As Long
Dim lngCnt As Long
Dim objDic As Object

Set objDic = CreateObject("scripting.dictionary")
X = Range([a1], Cells(Rows.Count, "C").End(xlUp)).Value2
Y = X

ReDim Y(1 To UBound(Y), 1 To 100)

For lngCnt1 = 1 To (UBound(Y, 2) - 3)
Y(1, lngCnt1) = "Name" & lngCnt1
Next

For lngRow = 1 To UBound(X, 1)
    If objDic.exists(X(lngRow, 1) & X(lngRow, 2) & X(lngRow, 3)) Then
'find first blank entry in relevant array row
        C = Split(Join(Application.Index(Y, lngCnt), "| "), "|")
        Y(lngCnt, Application.Match(" ", C, 0)) = X(lngRow, 4)
    Else
        lngCnt = lngCnt + 1
        Y(lngCnt, 1) = X(lngRow, 1)
        Y(lngCnt, 2) = X(lngRow, 2)
        Y(lngCnt, 3) = X(lngRow, 3)
        Y(lngCnt, 4) = X(lngRow, 4)
        objDic.Add X(lngRow, 1) & X(lngRow, 2) & X(lngRow, 3), lngCnt
    End If
Next

[f1].Resize(UBound(Y, 1), UBound(Y, 2)) = Y

End Sub

回答by mike27015

If you are going for a SQL request, you might take a look at triggers. First, you need to loop through your data.

如果您要进行 SQL 请求，则可能会查看触发器。首先，您需要遍历数据。

CREATE TRIGGER tg AFTER INSERT ON `myTable`
FOR EACH ROW
BEGIN
insert into myTable(MyNewName) values (Name);
END
;

Also you need to work with Alter Table in order to add a new column

您还需要使用 Alter Table 来添加新列

ALTER TABLE myTable
ADD MyNewName VARCHAR

http://www.w3schools.com/sql/sql_alter.asp

http://www.w3schools.com/sql/sql_alter.asp

And to make a comparison if Var1already exists you do an IF-condition

并进行比较，如果Var1已经存在，你做一个IF-condition

IF previousrecord = nextrecord 
BEGIN
     ALTER TABLE myTable
     ADD MyNewName VARCHAR
END

http://msdn.microsoft.com/fr-fr/library/ms182717.aspx

http://msdn.microsoft.com/fr-fr/library/ms182717.aspx

Now combine all of them with a trigger:

现在将所有这些与触发器结合起来：

CREATE TRIGGER tg AFTER INSERT ON `myTable`
FOR EACH ROW
BEGIN
      IF previousrecord = currentrecord // where at beginning previousrecord=firstrecord
      BEGIN
           ALTER TABLE myTable
           ADD MyNewName VARCHAR // MyNewName you can create a variable that increases
                                 // smth like $added=0 then increase it
           insert into myTable(MyNewName) values (Name);
      END

END
;

It is a supposition when you read the data from your input that it is sorted by ID. It's maybe not the final solution, but it is supposed to help you out.

当您从输入中读取数据时，假设数据是按 ID 排序的。这可能不是最终的解决方案，但它应该可以帮助您。

回答by pnuts

Formula-only requires quite a lot of explanation but is merely a sequence of operations that individually are quite familiar to many:

仅公式需要相当多的解释，但仅仅是许多人非常熟悉的一系列操作：

1. Select your four columns (say A:D).
2. Data > Outline – Subtotal with At each change in: ID, Use function: Count, Add subtotal to: check all, check Replace current subtotalsand Summary below dataand OK.
3. Filter A:E and for ColumnA choose Text Filters, Contains C, OK.
4. Enter, in B5 =B4and copy across to D5
5. In F5:

   =IF(COLUMN()<6+$E5,OFFSET($E5,COLUMN()-6-$E5,),"")

6. Copy F5 across to say Z5 (further to the right if necessary).
7. Copy B5:D5 and F5:Z5 down to last grouped row.
8. Unfilter (select all).
9. Copy whole sheet and paste over the top with Paste Special, Values.
10. Remove Allin Subtotal.
11. Filter ColumnA to select Grand Countand (Blanks)only.
12. Delete rows numbered in blue.
13. Delete ColumnA.
14. Drag D1 to E1 and append 1.
15. Drag E1 across to the right as far as required.
16. Delete ColumnD.

1. 选择您的四列（例如 A:D）。
2. 数据>纲要-小计与在每个变化：ID，使用功能：Count，添加小计：检查所有，检查Replace current subtotals和Summary below data和确定。
3. 过滤器 A:E 和 ColumnA 选择Text Filters，包含C，确定。
4. 在 B5 中输入=B4并复制到 D5
5. 在 F5 中：

   =IF(COLUMN()<6+$E5,OFFSET($E5,COLUMN()-6-$E5,),"")

6. 复制 F5 以说 Z5（如有必要，进一步向右）。
7. 将 B5:D5 和 F5:Z5 向下复制到最后一个分组行。
8. 取消过滤（全选）。
9. 复制整个工作表并使用“选择性粘贴”、“值”粘贴到顶部。
10. Remove All在小计中。
11. 过滤 ColumnA 以选择Grand Count且(Blanks)仅。
12. 删除以蓝色编号的行。
13. 删除 A 列。
14. 将 D1 拖到 E1 并附加1.
15. 根据需要向右拖动 E1。
16. 删除列 D。