时间戳

首页 > 解决方案 > Excel根据唯一ID将交叉表数据转换为纵向数据

excel - Excel根据唯一ID将交叉表数据转换为纵向数据

问题描述

我有一个以交叉表格式排列的 excel 文件，我需要对其进行纵向转换。

我有的：

|-id-|-f1-|-f2-|-f3-|
|-1--|-a--|-b--|-c--|
|-1--|-a--|-x--|-y--|
|-2--|-1--|null|-9--|
|-2--|-f--|-1--|null|      
|-2--|-a--|-v--|-2--|

我需要的：

|-id-|-f1-|-f2-|-f3-|-id-|-f1-|-f2-|-f3-|-id-|-f1-|-f2-|-f3-|
|-1--|-a--|-b--|-c--|-1--|-a--|-x--|-y--|null|null|null|null|
|-2--|-1--|null|-9--|-2--|-f--|-1--|null|-2--|-a--|-v--|-2--|

我需要一个可以在数百行/列上快速轻松地运行的宏或 VBA 代码，并自动将纵向排列的数据放入新工作表中。

我在网上找到了这个。它完全按照我的意愿覆盖文件，但是，您必须手动选择要组合的行。我正在寻找能够找到唯一 ID 并自行进行冷凝的东西。

Sub TransformOneRow()
'Updateby20131120
Dim InputRng As Range, OutRng As Range
xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Ranges to be transform :", xTitleId, 
InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Paste to (single cell):", xTitleId, 
Type:=8)
Application.ScreenUpdating = False
xRows = InputRng.Rows.Count
xCols = InputRng.Columns.Count
For i = 1 To xRows
    InputRng.Rows(i).Copy OutRng
    Set OutRng = OutRng.Offset(0, xCols + 0)
Next
Application.ScreenUpdating = True
End Sub

谢谢你的帮助！

- 更新 -

我还没有想出如何用宏来做到这一点，但这是一个体面的解决方法，它不是太费力或耗时，以防其他人有同样的问题：

https://www.excel-university.com/combine-rows-into-a-delimited-list/

并作为解决上述方法的一些问题的补充：

https://community.powerbi.com/t5/Desktop/Error-DataFormat-Error-We-couldn-t-convert-to-Number-Details/mp/150897#M65221

标签： excelvba

解决方案

这应该做你想要的。

Sub TryThis()

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:", "Kutools For Excel", 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

此外，请考虑使用 Power Query，您可以从下面的链接获得。

https://www.microsoft.com/en-us/download/details.aspx?id=39379

推荐阅读