串連細胞時有重複，而無需使用移調

Question

我使用下面的代碼 - 感謝@bonCodigo

Sub groupConcat() 
Dim dc As Object 
Dim inputArray As Variant 
Dim i As Integer 

    Set dc = CreateObject("Scripting.Dictionary") 
    inputArray = WorksheetFunction.Transpose(Sheets(1).Range("A2:B7").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(1).Range("D2").Resize(UBound(dc.keys) + 1) = _ 
       Application.Transpose(dc.keys) 
    Sheets(1).Range("E2").Resize(UBound(dc.items) + 1) = _ 
       Application.Transpose(dc.items) 

    Set dc = Nothing 
End Sub 

一個非常優雅的解決方案。不幸的是，我遇到了使用Transpose方法的限制。我有很長的字符串，我想使用上面的代碼進行連接。 任何幫助將不勝感激。

問候

Answer 1

This also uses a variant array but without the `Transpose`. It will ignore blank values to boot. 

It runs by column, then by row 

Sub Bagshaw() 
Dim allPosts As Variant 
Dim allPosts2 As Variant 
Dim lngRow As Long 
Dim lngCol As Long 
Dim lngCnt As Long 
Dim objDic As Object 

Set objDic = CreateObject("Scripting.Dictionary") 
allPosts = Range("A2:B5000").Value2 
ReDim allPosts2(1 To UBound(allPosts, 1) * UBound(allPosts, 2), 1 To 1) 

For lngCol = 1 To UBound(allPosts, 2) 
    For lngRow = 1 To UBound(allPosts, 1) 
     If Not objDic.exists(allPosts(lngRow, lngCol)) Then 
      If Len(allPosts(lngRow, lngCol)) > 0 Then 
       objDic.Add allPosts(lngRow, lngCol), 1 
       lngCnt = lngCnt + 1 
       allPosts2(lngCnt, 1) = allPosts(lngRow, lngCol) 
      End If 
     End If 
    Next 
Next 
Range("D2").Resize(UBound(allPosts2, 1)).Value2 = allPosts2 
End Sub 

Answer 2

Sub groupConcat() 
    Dim r As Range 
    Dim ro As Range 
    Dim myr As Range 
    Dim vcompt As Integer 

    vcompt = 0 

    Set ro = Range(Range("A2"), Range("A2").End(xlDown)) 

    For i = Range("A2").Row To Range("A2").End(xlDown).Row 
     Debug.Print Range("A" & i).Address 
     Set myr = ro.Find(what:=Range("A" & i).Value, after:=Range("A2").End(xlDown), Lookat:=xlWhole, SearchDirection:=xlNext) 

     If myr Is Nothing Or myr.Address = Range("A" & i).Address Then 

      mystr = Range("A" & i).Offset(0, 1).Value 
      Set r = Range(Range("A" & i), Range("A2").End(xlDown)) 

      Set myr = r.Find(what:=Range("A" & i).Value, Lookat:=xlWhole, SearchDirection:=xlNext) 
      If Not myr Is Nothing And r.Address <> Range("A2").End(xlDown).Address Then 
       Do While myr.Address <> Range("A" & i).Address 
        Debug.Print "r: " & r.Address 
        Debug.Print "myr: " & myr.Address 
        mystr = mystr & "; " & myr.Offset(0, 1).Value 
        Set myr = r.FindNext(myr) 
       Loop 
      End If 

      Range("D" & 2 + vcompt).Value = Range("A" & i).Value 
      Range("D" & 2 + vcompt).Offset(0, 1).Value = mystr 
      vcompt = vcompt + 1 

     End If 

    Next i 

End Sub