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

我试图找出一种方法来结合基于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 ?, ! 

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

我假设你在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 

编辑:请注意源数据被读入Variant数组V中 。 如果您在监视窗口中查看V,则会看到第一个维度表示行; 和第二维的列。 因此,如果您想要在不同的一组列上执行相同的过程,则只需在读取Set cCombData = New CombData的行下更改对第二个维度的引用即可。 例如,列B数据将是V(I,2)等等。 当然,你可能想要重新命名数据types,使它们更能代表你正在做的事情。

另外,如果你的数据从第2行开始,只需要用I = 2而不是I = 1来开始迭代。

编辑2:为了同时覆盖原文,并保持列的内容不被处理,以下修改将为列A,J和Z做这些。你应该能够修改它,无论你select处理任何列。

 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 

这是假设列J是关键和列A不需要被追加。 如果列A需要组合(不总是相同),那么您只需要为每个循环添加另一个循环来检查数据是否存在,如果不是,则添加它,如代码中第26列所做的那样。

 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