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

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

我假设您正在对Col 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 。如果在Watch Window中检查V，您将看到第一个维度代表行;列的第二个维度。因此，例如，如果您希望在不同的列集上执行相同的过程，则只需在读取Set cCombData = New CombData的行下更改对第二维的引用。例如，列B数据将是V（I，2），依此类推。当然，您可能希望重命名数据类型，以使它们更能代表您正在做的事情。

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

EDIT2：为了既覆盖原始列，也保留未处理列的内容，以下修改将对列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

Answer 2

这假设列J是键，而列A不需要追加。如果需要组合A列（并不总是相同），您只需要为每个循环添加另一个以检查数据是否存在，如果没有则添加它，如代码中的col 26所做的那样。 / p>

Sub CombineData()

    x = 2
    Do Until Cells(x, 1) = "" 'loop through every row in sheet starting at 2 (1 will never be removed, since it is the first data)
        x2 = 1
        Do Until x2 = x
            If Cells(x, 10) = Cells(x2, 10) Then 'this is comparing column J.  If another column is the reference then change 10 to the column number

                splt = Split(Cells(x, 26), ", ")
                For Each s In splt 'check to see if data already in column z
                    If s = Cells(x2, 26) Then GoTo alreadyEntered
                Next

                Cells(x, 26) = Cells(x, 26) & ", " & Cells(x2, 26) 'append column z data to row x
alreadyEntered:
                Rows(x2).Delete Shift:=xlUp 'delete duplicate row
                x = x - 1 'to keep x at same row, since we just removed a row
                Exit Do
            Else
                x2 = x2 + 1
            End If

        Loop

        x = x + 1
    Loop

End Sub

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

2 个答案: