VBA Excel中，拼接時有重複

Question

什麼我這裏是這樣

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的體面文檔。每一個建議表示讚賞。由於

Answer 1

This link用下面的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

這是另一種方式如果你想給它一個嘗試:)特別是如果你不想使用每行的函數，但有一個按鈕點擊輸出你想要的數據（大數據集）。

示例代碼：（您可能設置的片材，範圍根據你的）

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 

輸出：