排列表中的折叠数据

我有一个崩溃的数据如下所示，其中我有ID及其标题下面的头值其存在。 每个ID都有自己不同的标题和值。

我必须安排他们到一个表中，我已经将所有ID的标题合并成一行，这些ID在一列中。 基于一个ID我需要更新下面各自的标题的价值。

ID--+--H1--+--H2--+--H3--+--H4--+--H5--| 18219--V1--+--V3--+-- --+-- --+-- --| 18218--V2--+--V4--+-- --+-- --+-- --| 18217--V1--+--V2--+--V3--+--V4--+--V5--| 

谁能帮我吗？

Answer 1

试试这个代码：

 Option Explicit Sub Consolidate() Dim arrContent As Variant Dim strSource As String Dim strDest As String Dim x As Long Dim y As Long Dim p As Long Dim objHeader As Object Dim objItem As Variant Dim lngColsCount As Long ' set initial values strSource = "source" ' source worksheet name strDest = "destination" ' destination worksheet name y = 1 ' source worksheet first ID cell's row number x = 2 ' source worksheet first ID cell's column number Set objHeader = CreateObject("Scripting.Dictionary") ' pack source data into array of dictionaries objHeader.Add "ID", 0 arrContent = Array() With Sheets(strSource) Do While .Cells(y, x).Value <> "" And .Cells(y + 1, x).Value = "" Set objItem = CreateObject("Scripting.Dictionary") objItem.Add 0, .Cells(y, x).Value p = x + 1 Do While .Cells(y, p).Value <> "" If Not objHeader.Exists(.Cells(y, p).Value) Then objHeader.Add .Cells(y, p).Value, objHeader.Count objItem(objHeader(.Cells(y, p).Value)) = .Cells(y + 1, p).Value p = p + 1 Loop ReDim Preserve arrContent(UBound(arrContent) + 1) Set arrContent(UBound(arrContent)) = objItem y = y + 2 Loop End With ' output With Sheets(strDest) .Cells.Delete lngColsCount = UBound(objHeader.keys) .Range(.Cells(1, 1), .Cells(1, lngColsCount + 1)).Value = objHeader.keys y = 2 For Each objItem In arrContent For x = 1 To lngColsCount + 1 .Cells(y, x).Value = objItem(x - 1) Next y = y + 1 Next End With End Sub 

对于源表：

它会产生输出：