我有一个由三列组成的数据集，第一列中包含一组重复的UUID，第二列中每个UUID的字符串响应，以及第三列中每个响应的代码。我需要将其分解为多组列，每组重复一次UUID。见下图：
我有：
UUID RESPONSE Resp. Code
id1 String1 Code1
id2 String2 Code7
id3 String3 Code3
id1 String4 Code3
id2 String5 Code5
id3 String6 Code1
我需要：
UUID RESPONSE Resp. Code RESPONSE Resp. Code
id1 String1 Code1 String4 Code3
id2 String2 Code7 String5 Code5
id3 String3 Code3 String6 Code1
请注意，虽然这里有3个UUID，但我实际上是在处理1377。
我试图为此操作编写一个宏（粘贴在下面），但我是VBA和Excel宏的完整菜鸟，所以它很hacky，甚至没有关闭我想要它。
Sub DestackColumns()
Dim rng As Range
Dim iCell As Integer
Dim lastCol As Integer
Dim iCol As Integer
Set rng = ActiveCell.CurrentRegion
lastCol = rng.Rows(1).Columns.Count
For iCell = 3 To rng.Rows.Count Step 3
Range(Cells(1, iCell), Cells(2, iCell)).Cut
ActiveSheet.Paste Destination:=Cells(lastCol, 1)
Next iCell
End Sub
所有帮助表示赞赏！
答案 0 :(得分：1)
对实现此目的的VBA代码的一个看法是：
Sub DestackColumns()
Dim Source As Worksheet
Dim Output As Worksheet
Dim DistArr As Variant
Dim i As Integer
Dim j As Integer
Dim OutRow As Integer
Set Source = ActiveSheet
Sheets.Add After:=ActiveWorkbook.Sheets(ActiveSheet.Index)
Set Output = ActiveSheet
Output.Name = "Destack"
Output.Range("A1").Value = "UUID"
'Find distinct UUID's
DistArr = ReturnDistinct(Source.Range("A2:" & Source.Cells(Rows.Count, 1).End(xlUp).Address))
'Loop through distinct UUID's
For i = LBound(DistArr) To UBound(DistArr)
OutRow = Output.Cells(Rows.Count, 1).End(xlUp).Row + 1
Output.Cells(OutRow, 1).Value = DistArr(i)
'Loop source sheet
For j = 2 To Source.Cells(Rows.Count, 1).End(xlUp).Row
'IF UUID match
If Source.Cells(j, 1).Value = DistArr(i) Then
'Insert values
Output.Cells(OutRow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Source.Cells(j, 2).Value
Output.Cells(OutRow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Source.Cells(j, 3).Value
End If
Next j
Next i
End Sub
Private Function ReturnDistinct(InpRng) As Variant
Dim Cell As Range
Dim i As Integer
Dim DistCol As New Collection
Dim DistArr()
If TypeName(InpRng) <> "Range" Then Exit Function
'Add all distinct values to collection
For Each Cell In InpRng
On Error Resume Next
DistCol.Add Cell.Value, CStr(Cell.Value)
On Error GoTo 0
Next Cell
'Write collection to array
ReDim DistArr(1 To DistCol.Count)
For i = 1 To DistCol.Count Step 1
DistArr(i) = DistCol.Item(i)
Next i
ReturnDistinct = DistArr
End Function
此代码将新数据结构放在新工作表上（即不会覆盖原始数据），使用此代码，您无需担心数据是否正确排序。
答案 1 :(得分：0)
您的示例代码表示您希望删除原始值以支持新矩阵。为此，我建议首先在数据副本上运行它。
Sub stack_horizontally()
Dim rw As Long, mrw As Long
With ActiveSheet '<-set this worksheet name properly!
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
mrw = Application.Match(.Cells(rw, 1), .Columns(1), 0)
If mrw < rw Then
.Cells(mrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 2).Value
.Cells(mrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 3).Value
.Rows(rw).Delete
End If
Next rw
End With
End Sub
我没有将标题填充到新列中，但这应该是一个小的手动操作。
答案 2 :(得分：0)
这是一种有些不同的方法。我已经设置了一个名为cUUID的用户定义类。该类具有UUID，Response，ResponseCode和由配对的Response和ResponseCode组成的Collection的属性。
我们创建了这个类对象的Collection，其中集合的每个成员都是一个特定的UUID（因为那是你想要如何对它们进行分组）。
代码遍历您的数据源，即时创建这些对象＆＃34;＆＃34;。然后，我们创建一个包含所有结果的数组，并将此数组写入另一个工作表。
在代码中应该明白如何更改这些工作表名称，并在必要时更改源数据和结果的位置。
插入课程模块后，您必须选择F4并重命名 cUUID
Option Explicit
Private pUUID As String
Private pResponse As String
Private pRespCode As String
Private pCol As Collection
Public Property Get UUID() As String
UUID = pUUID
End Property
Public Property Let UUID(Value As String)
pUUID = Value
End Property
Public Property Get Response() As String
Response = pResponse
End Property
Public Property Let Response(Value As String)
pResponse = Value
End Property
Public Property Get RespCode() As String
RespCode = pRespCode
End Property
Public Property Let RespCode(Value As String)
pRespCode = Value
End Property
Public Property Get Col() As Collection
Set Col = pCol
End Property
Public Sub Add(Resp1 As String, RC As String)
Dim V(1 To 2) As Variant
V(1) = Resp1
V(2) = RC
Col.Add V
End Sub
Private Sub Class_Initialize()
Set pCol = New Collection
End Sub
Private Sub Class_Terminate()
Set pCol = Nothing
End Sub
Option Explicit
Sub ConsolidateUUIDs()
Dim cU As cUUID, colU As Collection
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim RespPairs As Long
Dim I As Long, J As Long
Set wsSrc = Worksheets("Sheet1")
Set wsRes = Worksheets("Sheet2")
Set rRes = wsRes.Cells(1, 1)
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, "C").End(xlUp))
End With
'Collect the data
Set colU = New Collection
RespPairs = 1
On Error Resume Next
For I = 2 To UBound(vSrc)
Set cU = New cUUID
With cU
.UUID = vSrc(I, 1)
.Response = vSrc(I, 2)
.RespCode = vSrc(I, 3)
.Add .Response, .RespCode
colU.Add cU, CStr(.UUID)
Select Case Err.Number
Case 457
Err.Clear
colU(CStr(.UUID)).Add .Response, .RespCode
J = colU(CStr(.UUID)).Col.Count
RespPairs = IIf(J > RespPairs, J, RespPairs)
Case Is <> 0
Debug.Print Err.Number, Err.Description
Stop
End Select
End With
Next I
On Error GoTo 0
'Sort Collection by UUID
CollectionBubbleSort colU, "UUID"
'Create Results Array
ReDim vRes(0 To colU.Count, 0 To RespPairs * 2)
'header row
vRes(0, 0) = "UUID"
For J = 0 To RespPairs - 1
vRes(0, J * 2 + 1) = "RESPONSE"
vRes(0, J * 2 + 2) = "Resp.Code"
Next J
'Data rows
For I = 1 To colU.Count
With colU(I)
vRes(I, 0) = .UUID
For J = 1 To colU(I).Col.Count
vRes(I, (J - 1) * 2 + 1) = colU(I).Col(J)(1)
vRes(I, (J - 1) * 2 + 2) = colU(I).Col(J)(2)
Next J
End With
Next I
'Write the results array
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2) + 1)
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
'-------------------------------------------------------
'Could use faster sort routine if necessary
Sub CollectionBubbleSort(TempCol As Collection, Optional Prop As String = "")
'Must manually insert element of collection to sort on in this version
Dim I As Long
Dim NoExchanges As Boolean
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For I = 1 To TempCol.Count - 1
If Prop = "" Then
' If the element is greater than the element
' following it, exchange the two elements.
If TempCol(I) > TempCol(I + 1) Then
NoExchanges = False
TempCol.Add TempCol(I), after:=I + 1
TempCol.Remove I
End If
Else
If CallByName(TempCol(I), Prop, VbGet) > CallByName(TempCol(I + 1), Prop, VbGet) Then
NoExchanges = False
TempCol.Add TempCol(I), after:=I + 1
TempCol.Remove I
End If
End If
Next I
Loop While Not (NoExchanges)
End Sub
UUID将按字母顺序排序。 代码应该适用于不同数量的UUID，以及对每个UUID的不同响应数。