使用 VBA 去除 Excel 中的列
De-Stacking columns in Excel using VBA
我有一个三列数据集，第一列是一组重复的 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
感谢所有帮助！
实现此目的的 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
此代码会将新的数据结构放在新的 sheet 上（即不会覆盖您的原始数据）并且使用此代码您无需担心数据是否正确排序。
您的示例代码表明您希望删除原始值以支持新矩阵。为此，我建议 运行 首先在数据副本上这样做。
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
我没有将 headers 填充到新列中，但这应该是一个小的手动操作。
这里有一个稍微不同的方法。我已经设置了一个名为 cUUID 的用户定义 class。 class 具有 UUID、Response、ResponseCode 和由成对的 Response 和 ResponseCode 组成的集合的属性。
我们创建这个 class 对象的集合，其中集合的每个成员都是一个特定的 UUID（因为这就是您想要对它们进行分组的方式）。
代码遍历您的数据源，创建这些对象 "on the fly"。然后我们创建一个包含所有结果的数组，并将此数组写入不同的工作表。
在代码中应该很明显如何更改这些工作表名称，以及在必要时更改源数据和结果的位置。
插入 Class 模块后，您必须 select 它， F4 并重命名它 cUUID
Class 模块
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 的不同数量的响应。
我有一个三列数据集，第一列是一组重复的 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
感谢所有帮助！
实现此目的的 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
此代码会将新的数据结构放在新的 sheet 上（即不会覆盖您的原始数据）并且使用此代码您无需担心数据是否正确排序。
您的示例代码表明您希望删除原始值以支持新矩阵。为此，我建议 运行 首先在数据副本上这样做。
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
我没有将 headers 填充到新列中，但这应该是一个小的手动操作。
这里有一个稍微不同的方法。我已经设置了一个名为 cUUID 的用户定义 class。 class 具有 UUID、Response、ResponseCode 和由成对的 Response 和 ResponseCode 组成的集合的属性。
我们创建这个 class 对象的集合，其中集合的每个成员都是一个特定的 UUID（因为这就是您想要对它们进行分组的方式）。
代码遍历您的数据源，创建这些对象 "on the fly"。然后我们创建一个包含所有结果的数组，并将此数组写入不同的工作表。
在代码中应该很明显如何更改这些工作表名称，以及在必要时更改源数据和结果的位置。
插入 Class 模块后，您必须 select 它， F4 并重命名它 cUUID
Class 模块
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 的不同数量的响应。