XL 2010 [résolu] [VBA] concatenation plage avec retour a la ligne et suppression de doublons

[ArQ]

Bonjour la communauté,

J'ai un problème que je souhaiterais vous soumettre : faire la concaténation d'une plage de 2000 cellules avec un retour à la ligne pour chaque concaténation, le tout sans doublon.

J'ai deux fonctions personnalisées (qui ne sont pas de moi) qui ne respecte que 50% du cahier des charges. Je fais donc appelle à toi, O communauté pour me venir en aide. Je répondrais humblement (et avec 6h de décalage horaire) à toutes questions qui permettront de répondre à cette problématique.

Function ConcatenateRange(ByVal cell_range As Range, _
Optional ByVal seperator As String) As String
Dim cell As Range
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long

cellArray = cell_range.Value

For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j))
End If
Next
Next

If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If

ConcatenateRange = newString

End Function

Function Concat(RowRange As Range) As String
  Dim X As Long, CellVal As String, ReturnVal As String, Result As String
  Const Delimiter = ", " 'CHAR(10) ne marche pas
    For X = 1 To RowRange.Count
    ReturnVal = RowRange(X).Value
    If Len(RowRange(X).Value) Then If InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) = 0 Then Result = Result & Delimiter & ReturnVal
  Next
  Concat = Mid(Result, Len(Delimiter) + 1)
End Function

Par avance, je vous remercie du temps passé sur mon cas.
Bien cordialement,

Arnaud

 

[mapomme]

Re : [VBA] concatenation plage avec retour a la ligne et suppression de doublons

Bonsoir ArQ,

Voir la fonction ConcateUnique (la cellule doit être au format "Renvoyer à la ligne automatique") :

Function ConcateUnique(xplage As Range) As String
Dim dico As Object, xcell As Range, elem
  Set dico = CreateObject("scripting.dictionary")
  For Each xcell In xplage: dico(xcell.Value) = vbNullString: Next xcell
  For Each elem In dico.keys: ConcateUnique = ConcateUnique & vbLf & elem: Next elem
  ConcateUnique = Mid(ConcateUnique, 2)
End Function

Si on ignore les cellules vides:

Function ConcateUniqueNoNull(xplage As Range) As String
Dim dico As Object, xcell As Range, elem
  Set dico = CreateObject("scripting.dictionary")
  For Each xcell In xplage: dico(xcell.Value) = vbNullString: Next xcell
  For Each elem In dico.keys
    If elem <> "" Then ConcateUniqueNoNull = ConcateUniqueNoNull & vbLf & elem
  Next elem
  ConcateUniqueNoNull = Mid(ConcateUniqueNoNull, 2)
End Function

 

[ArQ]

Re : [VBA] concatenation plage avec retour a la ligne et suppression de doublons

Grandiose, rapide et magnifique .... merci ! Je salue l'initiative de la suppression de cellule vide !
Ta/votre/vos(après update) marche parfaitement bien.

Curieusement, j'avais tenté d'utilisé vbLf sur la ligne Const Delimiter = de la fonction "Concat" mais il semblerait qu'elle ait été capricieuse ... elle marche a présent.

Je ferai un update du post pour indiquer le temps d’exécution entre nos deux formules. Mon fichier sera relativement lourd et je suis curieux de savoir qu'elle commande permettra l’exécution la plus rapide !

Mil merci pour avoir pris du temps sur cette problématique.
Passe(z) une très bonne soirée.

Bien cordialement et à très bientôt,
ArQ

 

[mapomme]

Re : [résolu] [VBA] concatenation plage avec retour a la ligne et suppression de doub

Re,

Une version 2 des fonctions qui est plus rapide (on passe par un tableau des valeurs à concaténer)

Voir fichier joint pour le test des temps d'exécution des quatre fonctions.