VBA Excel基于匹配的列单元格查找和合并行 [英] VBA Excel Finding and Combining Rows Based on Matching Column Cells

问题描述

我正在尝试找出一种基于vba excel中两个特定列中的值组合行的方法. 例如: 假设我有以下工作表:

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          !

我需要将其转换为此:

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

推荐答案

这是使用用户定义类型和集合来遍历列表并得出合并结果的另一种方法.对于大数据集，它应该比读取工作表中的每个单元格快快.

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.

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

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.

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

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

编辑:请注意，源数据被读入Variant数组 V 中.如果在监视窗口"中检查V，您将看到第一维代表行；第二维代表行.第二维是列.因此，例如，如果您想对不同的列集执行相同的过程，则只需更改对读取Set cCombData = New CombData的行下第二维的引用.例如，列B的数据将是V(I，2)，依此类推.当然，您可能想重命名数据类型，以使其更能代表您的工作.

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.

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

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

EDIT2 :为了覆盖原始内容，并保持未处理的列的内容，下面的修改将对A，J和Z列执行此操作.修改它以选择要处理的任何列.

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

这篇关于VBA Excel基于匹配的列单元格查找和合并行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！