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宏的完整菜鸟，所以它很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

所有帮助表示赞赏！

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

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

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

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

Answer 3

这是一种有些不同的方法。我已经设置了一个名为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的不同响应数。

使用VBA

3 个答案:

班级单元

常规模块