VBA Excel 基于匹配列单元格查找和组合行

Question

我正在尝试找出一种方法来根据 vba excel 中两个特定列中的值组合行。例如:假设我有以下表格:

Column A   Column J   Column Z
    1         A          ?
    1         A          !
    2         B          ?
    2         B          !

我需要将其转换为:

Column A   Column J   Column Z
    1         A         ?, !
    2         B         ?, !

Answer 1

这是另一种使用用户定义类型和集合来迭代列表并开发组合结果的方法。对于大量数据，它应该比读取工作表上的每个单元格快得多快。

我假设您在 J 列上进行分组，并且 A 列数据不需要在单元格中连接。如果是这样，对例程的修改将是微不足道的。

首先，插入一个类模块，将其重命名为CombData，并将以下代码插入到该模块中:

Option Explicit
Private pColA As String
Private pColJ As String
Private pColZConcat As String

Public Property Get ColA() As String
    ColA = pColA
End Property
Public Property Let ColA(Value As String)
    pColA = Value
End Property

Public Property Get ColJ() As String
    ColJ = pColJ
End Property
Public Property Let ColJ(Value As String)
    pColJ = Value
End Property

Public Property Get ColZConcat() As String
    ColZConcat = pColZConcat
End Property
Public Property Let ColZConcat(Value As String)
    pColZConcat = Value
End Property

然后插入常规模块并插入以下代码:

Option Explicit
Sub CombineData()
    Dim cCombData As CombData
    Dim colCombData As Collection
    Dim V As Variant
    Dim vRes() As Variant 'Results Array
    Dim rRes As Range   'Location of results
    Dim I As Long

'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)

'Set results range.  Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
'  original.  Area below and to right is cleared

Set rRes = Range("A1").Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear

Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
    Set cCombData = New CombData
    cCombData.ColA = V(I, 1)
    cCombData.ColJ = V(I, 10)
    cCombData.ColZConcat = V(I, 26)
    colCombData.Add cCombData, CStr(cCombData.ColJ)
    If Err.Number <> 0 Then
        Err.Clear
        With colCombData(cCombData.ColJ)
            .ColZConcat = .ColZConcat & ", " & V(I, 26)
        End With
    End If
Next I
On Error GoTo 0

ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
    With colCombData(I)
        vRes(I, 1) = .ColA
        vRes(I, 10) = .ColJ
        vRes(I, 26) = .ColZConcat
    End With
Next I

rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes

End Sub

编辑:请注意，源数据被读入变体数组V。如果您在观察窗口中检查 V，您将看到第一个维度代表行；第二个维度是列。因此，例如，如果您想要对一组不同的列执行相同的过程，您只需更改对 Set cCombData = New CombData 行下的第二个维度的引用即可。例如，B 列数据将为 V(I,2)，依此类推。当然，您可能想要重命名数据类型，使它们更能代表您正在做的事情。

此外，如果您的数据从第 2 行开始，只需以 I = 2 而不是 I = 1 的方式通过 V 开始迭代即可。

编辑2:为了覆盖原始数据，并保留未处理的列的内容，以下修改将对列 A、J 和 Z 执行此操作。您应该能够为您选择处理的任何列修改它。

Option Explicit
Sub CombineData()
    Dim cCombData As CombData
    Dim colCombData As Collection
    Dim V As Variant
    Dim vRes() As Variant 'Results Array
    Dim rRes As Range   'Location of results
    Dim I As Long, J As Long, K As Long

'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)

'Set results range.  Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
'  original.  Area below and to right is cleared

Set rRes = Range("A1")  '.Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear

Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
    Set cCombData = New CombData
    cCombData.ColA = V(I, 1)
    cCombData.ColJ = V(I, 10)
    cCombData.ColZConcat = V(I, 26)
    colCombData.Add cCombData, CStr(cCombData.ColJ)
    If Err.Number <> 0 Then
        Err.Clear
        With colCombData(cCombData.ColJ)
            .ColZConcat = .ColZConcat & ", " & V(I, 26)
        End With
    End If
Next I
On Error GoTo 0

ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
    With colCombData(I)
        vRes(I, 1) = .ColA
        vRes(I, 10) = .ColJ
        vRes(I, 26) = .ColZConcat

        'Note the 10 below is the column we are summarizing by
        J = WorksheetFunction.Match(.ColJ, WorksheetFunction.Index(V, 0, 10), 0)
        For K = 1 To 26
            Select Case K  'Decide which columns to copy over
                Case 2 To 9, 11 To 25
                    vRes(I, K) = V(J, K)
            End Select
        Next K
    End With
Next I

rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes

End Sub