在Excel中使用VBAparsing堆列
我有一个数据集，由三列组成，第一列是一组重复的UUID，第二列是每个UUID的string响应，第三列是每个响应的代码。 我需要将其分解成多组列，每个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。
我试图为这个操作写一个macros（在下面粘贴），但是我是VBA和Excelmacros的完全noobot，所以它是hacky，甚至不closures我想要的。
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
所有帮助赞赏！
这是一个有点不同的方法。 我build立了一个名为cUUID的用户定义的类。 该类具有UUID，Response，ResponseCode和由配对的Response和ResponseCode组成的集合的属性。
我们创build一个这个类对象的集合，其中集合的每个成员都是一个特定的UUID（因为这就是你想要的分组方式）。
代码遍历数据源，“即时创build”这些对象。 然后我们创build一个包含所有结果的数组，然后将这个数组写入一个不同的工作表中。
如何更改这些工作表名称，以及必要时更改源数据和结果的位置，这在代码中应该是显而易见的。
插入类模块后，必须select它， 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将按字母顺序sorting。 代码应该使用不同数量的UUID，以及对每个UUID的不同数量的响应。
一个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
这段代码将把新的数据结构放在一个新的表格中（即不会覆盖原来的数据），用这个代码你不必担心数据是否被正确sorting。
您的示例代码表示您希望删除原来的值，以支持新的matrix。 为此，我build议首先在数据的副本上运行这个。
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
我还没有将标题填充到新列中，但这应该是一个小手动操作。