Second tableau avec occurence distincte et liste de champs

Version imprimable

Bonsoir ,

J'ai un tableau excel qui est mis à jour toutes les nuits par un batch.

Ce tableau comporte 2 colonnes :

1 colonne avec un id client , 1 colonne avec le service vendu

Exemple :

client1;service1
client1;service3
client2;service1
client2;service2
client2;service4
client3;service3
client3;service4
client4;service5
client5;service2
client5;service3

Je souhaite que ceci me génère un nouvelle liste comme ceci :

client1;service1-service3-
client2;service1-service2-service4-
client3;service3 -service4-
client4;service5-
client5;service2-service3-
...

Pour cela il faut que le programme fasse :
- affecter l'id client dans un second tableau , si l'id client est déjà présent ne pas le réaffecté
- parcourir le tableau1 à l'aide du tableau 2
- on va comparer chaque cellule de l'id du tableau 1 à chaque la cellule de l'id du tableau 2
- si l'id de t1 = id de t2 j'affecte à une cellule dans une seconde colonne du tableau 2 la chaine présente dans la seconde colonne du tableau 1 , on renouvelle l'opération , si l'id de t1 = id de t2 on va maintenant concaténer la chaine qui contiendra le mot serviceX , si serviceX est déjà présent on affecte la valeur déjà existant avec la nouvelle

La liste doit se trouver comme ceci :

A1 = entête de l'id client du tableau 1
B1 = entête de la colonne du service vendu
reste de la colonne A = id client
reste de la colonne B = numéro du service vendu au client
colonne C = colonne vide

La liste résultat doit être comme ceci :

colonne D = colonne avec les id client distinct
colonne E = colonne avec les numéros de services vendu concaténés

Voici le programme :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 Option Explicit Option Base 0 Sub listing() Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer, n5 As Integer, n6 As Integer, n7 As Integer, n8 As Integer, n9 As Integer, n10 As Integer Dim compt1 As Integer, compt2 As Integer, compt3 As Integer, compt4 As Integer Dim c1 As String, c2 As String, c3 As String, c4 As String, c5 As String, c6 As String, c7 As String, c8 As String ' ActiveWorkbook.ActiveSheet.Cells(XXXX, XXXX).Values fait réference à la cellule active , c'est à dire la cellule ou se trouve le pointeur du programme VB dans la feuille de classeur Excel n1 = Range("BXXXX:BXXXX").End(xlUp).Row 'nombre de lignes à définir n3 = 1 ' ici n3= indice colonne 1 c1(XXXX) = ActiveWorkbook.ActiveSheet.Cells(XXXX, XXXX).Values 'ligne X= premier ou deuxieme ligne du tableau a voir pr num For n2 = XX To n1 ' boucle for n2 de 1 à la valeur de n1 = nb de ligne + ligne de départ à trouver If c1(n2 - 1) <> ActiveWorkbook.ActiveSheet.Cells(X, XXXX).Values Then ' ligne X= premier ou deuxieme ligne du tableau a voir pr num , si ligne du dessus identique ligne active c1(n2, n3) = ActiveWorkbook.ActiveSheet.Cells(X, XXXX).Values 'ligne X= premier ou deuxieme ligne du tableau a voir pr num Else: c1(n2 - 1) = ActiveWorkbook.ActiveSheet.Cells(X, XXXX).Values End If Next n4 = 2 ' ici n4= indice colonne 2 For n2 = XX To n1 ' boucle for n2 de 1 à la valeur de n1 = nb de ligne For n2 = XX To n1 ' boucle for n2 de 1 à la valeur de n1 = nb de ligne If ActiveWorkbook.ActiveSheet.Cells(X, XXXX).Values = c1(n2, n3) Then 'voir pour referencement cellule active colonne 1 et colonne 2 n6 = Len(c2) 'longueur de chaine c2 n5 = Len(ActiveWorkbook.ActiveSheet.Cells(X, XXXX).Values) ' preciser colonne 2 ou valeur texte a calculer longueur chaine c2 = ActiveWorkbook.ActiveSheet.Cells(X, XXXX).Values & "-" ' concatener valeur de colone 2 et le tiret n7 = n5 + n6 'longueur concatenation chaine c1(n2, n4) = c1(n2, n4) & c2 'concatenantion de valeur deja existante dans colonne 2 de c1 et ajout d'une nouvelle valeur à la chaine End If Next Next For n2 = XX To n1 ActiveWorkbook.ActiveSheet.Cells(XXXX, XXXX) = c1(n2, n3) ' voir affichage dans cellule MsgBox = Range("E" & n2) ActiveWorkbook.ActiveSheet.Cells(XXXX, XXXX) = c1(n2, n3) ' voir affichage dans cellule MsgBox = Range("F" & n2) Next End Sub
Merci de m'aiguiller , je m'arrache les cheveux pour faire marcher ce programme :pc:

Exemple basique à adapter

données en Feuil1 et résultat en Feuil2

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Formation()
Dim LastLig As Long, i As Long
 
Application.ScreenUpdating = False
'On copie les données vers la feuille Feuil2
With Worksheets("Feuil1")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A1:B" & LastLig).Copy Worksheets("Feuil2").Range("A1")
End With
 
 
With Worksheets("Feuil2")
'On tri les données sur la première et seconde colonne
    .Range("A1:B" & LastLig).Sort Key1:=.Range("A1"), Order1:=xlAscending, key2:=.Range("B1"), order2:=xlAscending, Header:=xlYes
 
    For i = LastLig To 3 Step -1
        If .Range("A" & i) = .Range("A" & i - 1) Then
            .Range("B" & i - 1) = .Range("B" & i - 1) & " - " & .Range("B" & i)
            .Rows(i).Delete
        End If
    Next i
End With
End Sub

Sinon, si beaucoup de données on pourra utiliser un dictionnaire mais c'est du niveau un peu plus poussé

Bonjour tanaka59,

l'algorithme présenté est logique mais il y a plus simple et plus rapide !
En complément du code de mercatog, en voici deux autres !

La première démonstration utilise les fonctions de feuilles de calculs EQUIV (Match en VBA) et INDEX :
Code:

1 2 3 4 5 6 7 8 9 10 Sub Demo1() VA = [A1].CurrentRegion.Value: ReDim RC$(1 To UBound(VA) - 1, 1 To 2) For R& = 2 To UBound(VA) V = Application.Match(VA(R, 1), Application.Index(RC, , 1), 0) If IsError(V) Then L& = L& + 1: RC(L, 1) = VA(R, 1): V = L RC(V, 2) = RC(V, 2) & VA(R, 2) & "-" Next [D2:E2].Resize(L).Value = RC End End Sub
La seconde fonctionne uniquement sous Windows à cause du dictionnaire évoqué par mercatog :
Code:

1 2 3 4 5 6 7 8 9 Sub Demo2() With CreateObject("Scripting.Dictionary") VA = [A1].CurrentRegion.Value For R& = 2 To UBound(VA): .Item(VA(R, 1)) = .Item(VA(R, 1)) & VA(R, 2) & "-": Next [D2:E2].Resize(.Count).Value = Application.Transpose(Array(.Keys, .Items)) .RemoveAll End With End End Sub
__________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …