cellules concaténer quand il y a des doublons sans utiliser Transposer

Question

Je suis en utilisant le code suivant - grâce @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 

Une solution très élégante. Malheureusement, je suis confronté à la limitation de l'utilisation de la méthode Transpose. J'ai de longues chaînes que je voudrais concaténer en utilisant le code ci-dessus. Toute aide sera appréciée.

Cordialement

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