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

Question

I'm trying to figure out a way to combine rows based on values in two specific columns in vba excel. For Example: Let's say I have the following sheet:

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

And I need to convert it to this:

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

Answer 1

Here's another method using User Defined Types and collections to iterate through the list and develop the combined results. For large sets of data, it should be considerably faster than reading through each cell on the worksheet.

I assume that you are grouping on Col J, and that Column A data does not need to be concatenated in the cell. If it does, the modifications to the routine would be trivial.

First, Insert a Class Module , rename it CombData and insert the following code into that module:

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

Then Insert a Regular Module and insert the Code Below:

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

EDIT: Note that the source data is read into the Variant array V . If you examine V in the Watch Window, you will see that the first dimension represents the rows; and the second dimension the columns. So if you wanted, for example, to perform the same procedure on a different set of columns, you would merely change the references to the second dimension under the line that reads Set cCombData = New CombData. For example, column B data would be V(I,2), and so forth. Of course, you might want to rename the data types to make them more representative of what you are doing.

In addition, if your data starts at row 2, merely start the iteration through V with I = 2 instead of I = 1.

EDIT2: In order to both overwrite the original, and also maintain the contents of the columns not being processed, the following modification will do that for Columns A, J and Z. You should be able to modify it for whatever columns you choose to process.

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

This is assuming that Column J is the key and Column A doesn't need to be appended. If Column A needs to be combined as well (not always the same), you would simply need to add another for each loop to check if the data is there, and add it if not, as done for col 26 in the code.

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