VBA excel，当有重复时连接单元格

我在这里是这样一个matrix

id value 1 A 2 B 3 C 1 D 3 E 1 F 

我需要做的就是总结一下我在价值上所具有的一些东西

  id value 1 A, D, F 2 B 3 C, E 

删除重复它将是很好，但不是强制性的。 我在第三列中尝试过这个公式，但是…

  =IF(COUNTIF(A:A,A1)>1,CONCATENATE(B1,",",VLOOKUP(A1,A1:B999,2)),B1) 

VLOOKUP只是给我一个值，这意味着我不能处理超过1个重复。

我曾尝试使用VBA，但这是我第一次，也变得越来越复杂，而且我也找不到有关excel VBA的体面的文档。 每一个build议表示赞赏。 谢谢

Answer 1

与以下VBA函数的链接可以帮助您：

 Function vlookupall(sSearch As String, rRange As Range, _ Optional lLookupCol As Long = 2, Optional sDel As String = ",") As String 'Vlookupall searches in first column of rRange for sSearch and returns 'corresponding values of column lLookupCol if sSearch was found. All these 'lookup values are being concatenated, delimited by sDel and returned in 'one string. If lLookupCol is negative then rRange must not have more than 'one column. 'Reverse("moc.LiborPlus.www") PB 16-Sep-2010 V0.20 Dim i As Long, sTemp As String If lLookupCol > rRange.Columns.Count Or sSearch = "" Or _ (lLookupCol < 0 And rRange.Columns.Count > 1) Then vlookupall = CVErr(xlErrValue) Exit Function End If vlookupall = "" For i = 1 To rRange.Rows.Count If rRange(i, 1).Text = sSearch Then If lLookupCol >= 0 Then vlookupall = vlookupall & sTemp & rRange(i,lLookupCol).Text Else vlookupall = vlookupall & sTemp & rRange(i).Offset(0,lLookupCol).Text End If sTemp = sDel End If Next i End Function 

Answer 2

如何数据透视表：D，然后将数据复制到任何你想要的地方：D

如果你不想为每一行使用一个函数，而只是点击button来输出你想要的数据（对于一个大的数据集），那么这是另一种方法，如果你想给它一个尝试:)。

示例代码:(您可以根据您的设置表单，范围）

 Option Explicit Sub groupConcat() Dim dc As Object Dim inputArray As Variant Dim i As Integer Set dc = CreateObject("Scripting.Dictionary") inputArray = WorksheetFunction.Transpose(Sheets(4).Range("Q3:R8").Value) '-- assuming you only have two columns - otherwise you need two loops For i = LBound(inputArray, 2) To UBound(inputArray, 2) If Not dc.Exists(inputArray(1, i)) Then dc.Add inputArray(1, i), inputArray(2, i) Else dc.Item(inputArray(1, i)) = dc.Item(inputArray(1, i)) _ & "," & inputArray(2, i) End If Next i '--output into sheet Sheets(4).Range("S3").Resize(UBound(dc.keys) + 1) = _ Application.Transpose(dc.keys) Sheets(4).Range("T3").Resize(UBound(dc.items) + 1) = _ Application.Transpose(dc.items) Set dc = Nothing End Sub 

输出：