使用 VBA 在 Excel 中取消堆叠列

Question

我有一个三列数据集，第一列是一组重复的 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 宏的菜鸟，所以它很老套，甚至无法关闭我想要的功能。

    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

感谢所有帮助！

Answer 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

此代码会将新数据结构放置在新工作表上（即不会覆盖您的原始数据），使用此代码您无需担心数据是否正确排序。

Answer 2

这里是一个有些不同的方法。我已经建立了一个名为 cUUID 的用户定义类。该类具有 UUID、Response、ResponseCode 和由成对的 Response 和 ResponseCode 组成的 Collection 的属性。

我们创建这个类对象的集合，其中集合的每个成员都是一个特定的 UUID（因为这就是您想要对它们进行分组的方式）。

代码遍历您的数据源，“即时”创建这些对象。然后我们创建一个包含所有结果的数组，并将这个数组写入不同的工作表。

如何更改这些工作表名称以及（如有必要）源数据和结果的位置应该在代码中很明显。

插入类模块后，必须选择它，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 的不同数量的响应。

Answer 3

您的示例代码表明您希望删除原始值以支持新矩阵。为此，我建议先在数据副本上运行它。

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

我没有将标题填充到新列中，但这应该是一个小的手动操作。