Excel – VBA – 以水平方式排列垂直inputID的参数
我是VBA新手，长期以来一直在寻找解决scheme。 我需要数据来执行Vlookup与另一组数据具有共同的ID我有数据如下给出。
ID Status Package 0001 ACT Gold 0001 ACT SSA 0001 ACT SP 0002 ACT Silver 0003 DIS SSA 0003 DIS SSB 0004 ACT PT 0005 DIS NP 0006 DIS <Blank >
我需要它在以下结构中
ID Status Package1 Package 2 Package 3…. 0001 ACT Gold SSA SP 0002 ACT Silver 0003 DIS SSA SSB 0004 ACT PT 0005 DIS NP 0006 DIS
包裹的数量可以从0到15变化。
另外如何做逆向操作？ （二级要求）
试过这个代码（！），但是结果为1或没有参数的值是不准确的。
Sub test() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary") Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key ' Sheet1 is a Source Sheet ' Sheet3 is a Target Sheet x = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row For Each CLa In Sheets("Sheet1").Range("A1:A" & x) If Not Dic.exists(CStr(CLa.Value)) Then ID = CLa.Value ' Sheet1 is a Source Sheet ' Sheet3 is a Target Sheet For Each CLb In Sheets("Sheet1").Range("A1:A" & x) If CLb.Value = ID Then If Names = "" Then Names = CLb.Offset(, 2).Value Else Names = Names & "," & CLb.Offset(, 2).Value End If End If Next CLb Dic.Add ID, Names End If ID = Empty: Names = Empty Next CLa x = 1 For Each Key In Dic Sheets("Sheet3").Cells(x, 1).Value = Key Sheets("Sheet3").Range(Cells(x, 2), Cells(x, 4)) = Split(Dic(Key), ",") x = x + 1 Next Key Sheets("Sheet3").Cells.Replace "#N/A", Replacement:="" End Sub
我会用一个简单的公式：
= “包” ＆COUNTIF（$ A $ 1：$ A2; A2）
它会创build您的匹配名称，然后您可以使用枢轴进行总结。 当然，你可以设置每个单独的ID循环。
相反，更棘手的是，我会采取一些行动
Sub ertdfgcvb() Dim ws As Worksheet, wsex As Worksheet, k As Long, i As Long, j As Long, LastRow As Long Set ws = Sheets("tabular form") Set ws = Sheets("dataset form") k = 2 LastRow = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row For i = 2 To LastRow 'from the second to the last row j = 3 'start at Package1 While Not IsEmpty(ws.Cells(i, j)) wsex.Cells(k, 1).Value2 = ws.Cells(i, 1).Value2 'copies the ID from the A column wsex.Cells(k, 2).Value2 = ws.Cells(i, 2).Value2 'Copies status likewise wsex.Cells(k, 3).Value2 = ws.Cells(i, j).Value2 'copies Package<n> 'wsex.Cells(k, 4).Value2 = "Package" & j - 2 'copies "Package<n>" k = k + 1 'increases counters j = j + 1 Wend Next i End Sub
这可以通过一个简单的循环来完成
Sub Transpose() writeRow = 1 LastRow = Columns(1).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row For i = 2 To LastRow If Cells(i, 1).Value <> currentID Then 'New ID writeRow = writeRow + 1 currentID = Cells(i, 1).Value Cells(writeRow, 5).Value = currentID Cells(writeRow, 6).Value = Cells(i, 2).Value Cells(writeRow, 7).Value = Cells(i, 3).Value Else 'Continue from old ID Cells(writeRow, Rows(writeRow).Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1).Value = Cells(i, 3).Value End If Next i End Sub
我没有读到你也需要一个逆向例程。 试试这些：
Sub Transpose() Cells(2, 5).CurrentRegion.ClearContents writeRow = 1 For i = 2 To Columns(1).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row If Cells(i, 1).Value <> currentID Then 'New ID writeRow = writeRow + 1 currentID = Cells(i, 1).Value Cells(writeRow, 5).Value = currentID Cells(writeRow, 6).Value = Cells(i, 2).Value Cells(writeRow, 7).Value = Cells(i, 3).Value writeCol = 8 Else 'Continue from old ID Cells(writeRow, writeCol).Value = Cells(i, 3).Value writeCol = writeCol + 1 End If Next i End Sub Sub ReverseTranspose() Cells(2, 1).CurrentRegion.ClearContents writeRow = 1 For i = 2 To Columns(5).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row For j = 7 To WorksheetFunction.Max(7, Rows(i).Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column) writeRow = writeRow + 1 currentID = Cells(i, 5).Value Cells(writeRow, 1).Value = currentID Cells(writeRow, 2).Value = Cells(i, 6).Value Cells(writeRow, 3).Value = Cells(i, j).Value Next j Next i End Sub