Séparer des contacts dans une même cellule et compter leur valeur associée

[Ben_R]

Bonjour à tous, je bute sur un problème :

J’ai une liste de contacts avec 2 colonnes comme suit :
Une Colonne avec plusieurs contacts séparés par des points virgules
Une colonne avec un nombre associé à chaque ligne

Je souhaite isoler chaque contact et obtenir le nombre associé à la ligne ou il était


Colonne 1 Colonne 2
Pierre jean; sylvian dufour 3
Guillaume Le Breton ; Guillaume Gilles, Martin de Normandie 2


Afin d’obtenir les résultats comme suit :

Colonne 1 Colonne 2
Pierre jean 3
Sylvian dufour 3
Guillaume le breton 2
Guillaume Gilles 2
Martin de Normandie 2


Merci par avance pour votre aide précieuse !

Cordialement

 

[Usine à gaz]

Bonjour Ben_R,
Joindre un fichier test avec tes infos à traiter te permettra de recevoir des réponses.
Amicalement,
Arthour973

 

[Ben_R]

Bonjour Arthour973,

Merci pour ce conseil.
Voici le fichier avec les infos à traiter.

Cordialement,

 

[Lone-wolf]

Bonjour Ben_R et bienvenue sur XLD

C'est bien de mettre le résultat excompté, mais comme s'appelle le fichier source et dans quelle colonne sont les noms???

 

[Usine à gaz]

Bonjour Bonjour Ben_R,, re-Lone, le forum,

Une p'tite solution de profane LOL.

Evidemment, on peut automatiser par macro mais pour cela, il faudrait que les cellules à traiter soient dans une feuille séparée de la feuille du résultat attendu.

Voire pièce jointe.
Amicalement,
Arthour973

 

[Ben_R]

Merci pour ton retour Profane LOL.

Cependant cela ne résout pas mon problème. J'ai des milliers de lignes à traiter et le fichier fourni n'est qu'un exemple. Je recherche donc une formule qui m'éviterai de devoir faire çà manuellement...

 

[Usine à gaz]

OK, alors envoies un fichier test plus significatif pour peut-être obtenir la solution appropriée

 

[Ben_R]

Voici un fichier plus représentatif.

La colonne 1 correspond au noms des contacts et la colonne 2 au nombre de visites
Je souhaite obtenir une colonne avec un contact unique par ligne , et le nombre de visites associées dans la seconde colonne. (comme sur l'exemple du premier fichier).

Merci

 

[Lone-wolf]

Re

Voici le code de séparation, mais il faut enregistrer au format .xlsm. À mettre dans le classeur de destination.

Option Explicit
Sub test1()
Dim c As Range, Item As Variant, Ligne As Long, Plage As Range, Ctr As Integer
    Ligne = 1
    With Sheets("Feuil1")
        Set Plage = .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
        For Each c In Plage
            Ctr = c.Offset(, -1).Value
            If c.Value <> "" Then
                For Each Item In Split(c.Value, "; ")
                    Ligne = Ligne + 1
                    If Ctr <> 0 Then
                        .Cells(Ligne, 2) = Ctr
                        Ctr = 0
                    End If
                    .Cells(Ligne, 5) = Item
                Next Item
            End If
        Next c
    End With
End Sub

 

[Usine à gaz]

Re-bonjour à toutes et à tous,

Je pense avoir une solution de profane mais il me faut un peu de temps pour coder.
Je ferai ça ce soir

 

[Ben_R]

Re

Voici le code de séparation, mais il faut enregistrer au format .xlsm. À mettre dans le classeur de destination.

Option Explicit
Sub test1()
Dim c As Range, Item As Variant, Ligne As Long, Plage As Range, Ctr As Integer
    Ligne = 1
    With Sheets("Feuil1")
        Set Plage = .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
        For Each c In Plage
            Ctr = c.Offset(, -1).Value
            If c.Value <> "" Then
                For Each Item In Split(c.Value, "; ")
                    Ligne = Ligne + 1
                    If Ctr <> 0 Then
                        .Cells(Ligne, 2) = Ctr
                        Ctr = 0
                    End If
                    .Cells(Ligne, 5) = Item
                Next Item
            End If
        Next c
    End With
End Sub

Super merci Lone_wolf, ca marche exactement comme il faut.
Il ne me manque plus qu'à renvoyer la valeur de la colonne 2 en face de chaque contact. Une idée ?

Merci beaucoup

 

[laurent950]

Bonsoir

Comme ceci :
Super code Lone_wolf, j'ai refait différemment pour ajouté le nombre de consultation
associé au nom. cela fait une autres solution merci aussi pour votre solution

Sympa votre avatar Caliméro Ce lien n'existe plus, Super votre explication pour extraire les chaines
de caractères via Excel. encore une autre solution merci a vous aussi

Option Explicit

Sub test1()
Dim plage As Variant
Dim i As Long
Dim TabRs As Variant
Dim j As Integer

    With Sheets("Feuil1")
        .Range(.Cells(2, 5), .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row, 6)).ClearContents
        .Cells(1, 5) = "Nom"
        .Cells(1, 6) = "Compteur"
        plage = .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 3))
        For i = LBound(plage, 1) To UBound(plage, 1)
            TabRs = Split(plage(i, 1), ";")
                For j = LBound(TabRs, 1) To UBound(TabRs, 1)
                        .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row + 1, 5) = Trim(TabRs(j))
                        ' Rajout
                        .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row + 1, 6) = plage(i, 2)
                Next j
        Next i
    End With
End Sub

ReEdit Code solution 2

Option Explicit

Sub test2()
Dim F1 As Worksheet
    Set F1 = Worksheets("Feuil1")

Dim plage() As Variant
    plage = F1.Range(F1.Cells(2, 2), F1.Cells(F1.Cells(F1.Rows.Count, 2).End(xlUp).Row, 3))
        F1.Cells(1, 5) = "Nom"
        F1.Cells(1, 6) = "Compteur"

Dim i As Long
Dim j As Integer
Dim TabRs() As String
    For i = LBound(plage, 1) To UBound(plage, 1)
        TabRs = Split(plage(i, 1), ";")
            F1.Cells(F1.Cells(F1.Rows.Count, 5).End(xlUp).Row + 1, 5).Resize(UBound(TabRs) + 1) = Application.Transpose(TabRs)
                For j = LBound(TabRs, 1) To UBound(TabRs, 1)
                    TabRs(j) = plage(i, 2)
                Next j
                    F1.Cells(F1.Cells(F1.Rows.Count, 6).End(xlUp).Row + 1, 6).Resize(UBound(TabRs) + 1) = Application.Transpose(TabRs)
    Erase TabRs
    Next i
Erase plage, TabRs
Set F1 = Nothing
i = Empty
j = Empty
End Sub

Laurent

 

[Lone-wolf]

Bonsoir à tous

Merci Laurent et merci à Ben_R.
@laurent950 : ton code est encore mieux.

 

[Lone-wolf]

Re Laurent

je viens de faire un test sur le classeur source, la macro que tu as fait tourne lentement; le classeur reste bloqué plusieures secondes.

 

[Lone-wolf]

Re

La macro au complet et plus rapide (sans vouloir offenser), finalisée par Laurent950.

Option Explicit

Sub test2()
Dim plage As Range, cel As Range, Item As Variant
Dim ligne As Long, derlig As Long, nb As Long

    Application.ScreenUpdating = False
    ligne = 1

    With Sheets("Feuil1")
        derlig = .Range("f" & Rows.Count).End(xlUp).Row
        .Range("f1:g" & derlig).ClearContents
   
        Set plage = .Range("b2", .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 3))
   
        For Each cel In plage
            If cel.Value <> "" And Not IsNumeric(cel.Value) Then
                nb = cel.Offset(0, 1).Value
                For Each Item In Split(cel.Value, "; ")
                    ligne = ligne + 1
                    .Cells(ligne, 6) = Item
                    .Cells(ligne, 7) = nb
                Next Item
            End If
        Next cel
   
        .Cells(1, 6) = "NOMS"
        .Cells(1, 7) = "R.D.V."
        .Range("F:G").Columns.AutoFit
    End With
End Sub

@Ben_R : moi j'aurais mis "et assembler leurs valeurs associées" dans le titre du message.