Concaténation de données de 2 tableaux

Version imprimable

Bonjour à tous,

J'ai 2 fichiers dont les valeurs changent constamment:

1 contenant plus ou moins 16.000 lignes sur 4 colonnes

Prénom Id Agent Ville Langue

Alain 111 Liège FR

Marc 112 Charleroi FR

André 123 Namur FR

Henry 124 Namur FR

J'ai un autre fichier de plus ou moins 45.000 lignes sur 4 colonnes

Prénom Id Agent Skill Level

Alain 111 H_REP 4

Alain 111 T_SEP 3

Alain 111 R_TEC 4

Marc 112 H_REP 4

Marc 112 T_SEP 3

André 123 R_TEC 4

André 123 P_BOC 3

Henry 124 T_SEP 2

Henry 124 P_BOC 4

Et j'aimerais que les valeurs de la troisième colonne du tableau 2 deviennent des entêtes de colonnes a la suite du tableau 1 et afficher le level correspondant.

Prénom Id Agent Ville Langue T_SEP H_REP P_BOC R_TEC

Alain 111 Liège FR 3 4 4

Marc 112 Charleroi FR 3 4

André 123 Namur FR 3 4

Henry 124 Namur FR 2 4

Et je bloque....

Auriez-vous un moment pour me fournir une piste svp ?

Soit en formule soit en VBA suivant la rapidité d'exécution.

Je vous remercie d'avance.

Didier

Bonjour,

une p'tite démonstration à partir des tableaux en exemple regroupés dans deux feuilles d'un même classeur,
à adapter donc à ton contexte :

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
Sub Demo()
    With Feuil2.Cells(1).CurrentRegion.Columns
        C& = .Count + 2
        TS = .Value
        .Item(3).AdvancedFilter xlFilterCopy, , .Cells(1, C), True
             .Cells(1, C).Clear
        With .Cells(2, C).CurrentRegion
            VH = Application.Transpose(.Value)
            .Clear
        End With
            Feuil1.Cells(1).End(xlToRight)(1, 2).Resize(, UBound(VH)).Value = VH
    End With
    With Feuil1.Cells(1).CurrentRegion.Columns
            VI = .Item(2).Value
        With .Item(.Count - UBound(VH) + 1).Resize(, UBound(VH))
                VA = .Value
            For R& = 2 To UBound(TS)
                 V = Application.Match(TS(R, 2), VI, 0)
                If IsNumeric(V) Then VA(V, Application.Match(TS(R, 3), VH, 0)) = TS(R, 4)
            Next
                .Value = VA
        End With
    End With
End Sub

_________________________________________________________________________________________________________

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

_________________________________________________________________________________________________________

Je suis Paris, Nice, Bruxelles, Charlie, …

26/11/2016, 21h52
Ditch3122

Bonsoir Marc,

C'est exactement ce qu'il me fallait, le code fonctionne parfaitement avec quelques adaptations suivant mes besoins, je te remercie.

Didier
26/11/2016, 22h14
RyuAutodidacte

Bonsoir,

Pour Marc : j'aime voir ce type de code élégant et subtile ;) Ça me rappelle ceux que je décortiqués :D

je t'ai mis :plusser:

Bonsoir Marc-L, RyuAutodidacte, Ditch3122 :D

Avec 2 dictionnaires :

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
Option Explicit
Sub test()
Dim a, b, res(), i As Long, j As Long, n As Long, t As Byte
Dim txt As String, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    'le 1er tableau en feuil1
    With Sheets("Feuil1").Range("a1").CurrentRegion
        a = .Value: t = 4
        ReDim res(1 To UBound(a, 1), 1 To UBound(a, 2))
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
                n = n + 1: .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    res(.Item(txt), j) = a(i, j)
                Next
            Next
            'le 2eme tableau en feuil2
            b = Sheets("Feuil2").Range("a1").CurrentRegion.Value
            For i = 2 To UBound(b, 1)
                txt = Join(Array(b(i, 1), b(i, 2)), Chr(2))
                If Not dico.exists(b(i, 3)) Then
                    t = t + 1: dico(b(i, 3)) = t
                    If UBound(res, 2) < t Then
                        ReDim Preserve res(1 To UBound(res, 1), 1 To UBound(res, 2) + 1)
                        res(1, t) = b(i, 3)
                    End If
                End If
                res(.Item(txt), dico(b(i, 3))) = b(i, 4)
            Next
        End With
    End With
    'la restitution en feuil3
    Application.ScreenUpdating = False
    With Sheets("Feuil3").Range("a1")
        With .Resize(n, t)
            .CurrentRegion.Clear
            .Value = res
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            With .Rows(1)
                .Font.Bold = True
                .BorderAround Weight:=xlThin
                .Interior.ColorIndex = 44
            End With
            .Parent.Activate
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

26/11/2016, 23h31
Ditch3122

Tout-à-fait d'accord avec toi RyuAutodidacte, le code de Marc est vraiment sympa à voir et à analyser, très clair ce qui facilite les adaptations.

Klin89,

Je viens de tester ton code est la vitesse d'exécution est vraiment bluffante...

Je n'ai jamais travaillé avec les dictionnaires mais ça donne envie.

Je sens que je vais passer un bon moment à décrypter ton code.

Merci

Merci ! J'ai réalisé la p'tite démonstration avec le B-A-BA d'Excel (donc niveau débutant)
mais effectivement vu le nombre de lignes à traiter mieux vaut envisager un dictionnaire.

Klin89 je ne comprends pas dans ton code à la jindon pourquoi tu concatènes des colonnes en clef alors que l'Id seul suffit !

Avec deux dictionnaires, activer au préalable la référence Microsoft Scripting Runtime via le menu Outils du VBE :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub Demo2Dict() Dim oDic(1) As New Dictionary, C&, L&, R&, V, W With Feuil1.Cells(1).CurrentRegion C = .Columns.Count + 1 R = .Rows.Count V = .Columns(2).Value End With For L = 2 To R: oDic(1).Item(V(L, 1)) = oDic(1).Count + 2: Next V = Feuil2.Cells(1).CurrentRegion.Columns("B:D").Value For L = 2 To UBound(V) If Not oDic(0).Exists(V(L, 2)) Then oDic(0).Item(V(L, 2)) = oDic(0).Count + 1 Next ReDim W(1 To R, 1 To oDic(0).Count) For L = 1 To oDic(0).Count: W(1, L) = oDic(0).Keys(L - 1): Next For L = 2 To UBound(V) If oDic(1).Exists(V(L, 1)) Then W(oDic(1).Item(V(L, 1)), oDic(0).Item(V(L, 2))) = V(L, 3) Next Feuil1.Cells(C).Resize(R, oDic(0).Count).Value = W Erase oDic, V, W End Sub
_________________________________________________________________________________________________________

Merci de cliquer sur :plusser: si vous appréciez ce code !

27/11/2016, 11h16
Ditch3122

Bonjour Marc,

Parfait aussi avec ton 2ème code, très rapide donc je vais me tourner vers ce genre-là.

Par contre, je n'arrive plus à le modifier pour moi, enfin je suis entrain d'essayer, j'explique:

En Feuil1, j'importe 33 colonnes sur 4.500 lignes venant d'un autre fichier
En Feuil2, j'importe 12 colonnes sur 45.000 lignes venant d'un autre fichier

Seules les colonnes A (Nom) et B (Id_Tech) sont communes aux 2 feuilles mais la colonne de référence doit être la A (Nom) car j'ai des Id_Tech qui servent 2 fois et avec ce code-ci, seul "Marc, Zone3" est rempli, "Marc, Zone2" et "Marc" sont vides, chose qui n'arrivait pas avec le code de Klin89, je ne comprenais pas non plus sa concaténation mais du coup, ça m'arrangeait bien, je l'avais modifié dans ton premier code mais ici c'est moins simple pour moi:

Nom Id_Tech

Marc 111

Marc, zone2 111

Marc, Zone3 111

Eric 122

La colonne Skill est en Feuil2 colonne 10 et le level est en Feuil2 colonne 11 et ce sont les seules valeurs dont j'ai besoin en Feuil1 à la suite des cellules existantes.

Merci
27/11/2016, 16h13
Marc-L

Si la clef ne peut pas être une colonne unique mais à la fois par exemple sur le nom et l'Id
alors effectivement il faut en passer par une concaténation comme effectuée par Klin89 …

Dans le cas contraire il suffit juste de choisir la bonne colonne comme clef, faut-il encore ne pas y avoir de doublon ou d'homonyme !

Sinon en cas de difficulté joindre un classeur xlsx (donc sans code) avec les feuilles sources (pas besoin d'un millier de lignes)
et une feuille pour le résultat attendu en précisant si le résultat doit être situé dans une feuille séparée
ou en mise à jour de la première feuille …

Merci Marc,

Pour l'instant, j'ai adapté le code de Klin 89 qui fonctionne très bien

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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
Option Explicit
Sub test()
 
Dim a, b, res(), i As Long, j As Long, n As Long, t As Byte
Dim txt As String, dico As Object
 
'Vide la feuille 3
Sheets(3).Cells.Delete Shift:=xlUp
 
'Importe les données des feuilles 1 et 2
ActiveWorkbook.RefreshAll
 
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
 
'le 1er tableau en feuil1
With Sheets(1).Range("a1").CurrentRegion
 
    a = .Value: t = .Cells(1, Cells.Columns.Count).End(xlToLeft).Column
 
    ReDim res(1 To UBound(a, 1), 1 To UBound(a, 2))
 
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
            n = n + 1: .Item(txt) = n
 
            For j = 1 To UBound(a, 2)
                res(.Item(txt), j) = a(i, j)
            Next
        Next
 
 
        'le 2eme tableau en feuil2
        b = Sheets(2).Range("a1").CurrentRegion.Value
 
        For i = 2 To UBound(b, 1)
            txt = Join(Array(b(i, 1), b(i, 2)), Chr(2))
            If Not dico.Exists(b(i, 10)) Then
                t = t + 1: dico(b(i, 10)) = t
                If UBound(res, 2) < t Then
                    ReDim Preserve res(1 To UBound(res, 1), 1 To UBound(res, 2) + 1)
                    res(1, t) = b(i, 10)
                End If
            End If
 
            res(.Item(txt), dico(b(i, 10))) = b(i, 11)
        Next
    End With
End With
 
 
'la restitution en feuil3
Application.ScreenUpdating = False
With Sheets(3).Range("a1")
    With .Resize(n, t)
        .CurrentRegion.clear
        .Value = res
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        With .Rows(1)
            .Font.Bold = True
            .BorderAround Weight:=xlThin
            .Interior.ColorIndex = 44
        End With
        .Parent.Activate
    End With
End With
 
 
'Vide les tableaux en feuille 1 et 2
Dim Plg As Range
 Set Plg = Sheets(1).Range("Tech")
 Plg.ClearContents
 Set Plg2 = Sheets(2).Range("Skill")
 Plg2.ClearContents
 
Application.ScreenUpdating = True
 
ActiveWorkbook.Save
 
End Sub

Néanmoins, je suis interpellé par ton code et j'aimerais aussi le comprendre, je vais faire un petit fichier exemple.

Ce fichier va bien me servir pour une tâche particulière mais j'ai aussi une autre demande avec un import supplémentaire de 200.000 lignes et je me demande s'il serait possible de faire tout d'un coup, je suppose que ce serait mieux de créer un nouveau topic.

Je te remercie.

Didier

Mise à jour suite au post #8 :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub Demo2DictA()
        Dim oDic(1) As New Dictionary, C&, L&, R&, V, W
    With Feuil1.Cells(1).CurrentRegion
        C = .Columns.Count + 1
        R = .Rows.Count
        V = .Columns("A:B").Value
    End With
        For L = 2 To R:  oDic(1).Item(V(L, 2) & V(L, 1)) = oDic(1).Count + 2:  Next
    With Feuil2.Cells(1).CurrentRegion
        V = Application.Index(.Value, Evaluate("ROW(2:" & .Rows.Count & ")"), [{1,2,10,11}])
    End With
    For L = 1 To UBound(V)
        If Not oDic(0).Exists(V(L, 3)) Then oDic(0).Item(V(L, 3)) = oDic(0).Count + 1
    Next
        ReDim W(1 To R, 1 To oDic(0).Count)
        For L = 1 To oDic(0).Count:  W(1, L) = oDic(0).Keys(L - 1):  Next
    For L = 1 To UBound(V)
        If oDic(1).Exists(V(L, 2) & V(L, 1)) Then W(oDic(1).Item(V(L, 2) & V(L, 1)), oDic(0).Item(V(L, 3))) = V(L, 4)
    Next
        Feuil1.Cells(C).Resize(R, oDic(0).Count).Value = W
        Erase oDic, V, W
End Sub

Si ce n'est pas cela, alors joindre un fichier comme expliqué post #9 …

Les 2 1er Dico proposé Klin89 et Marc-L mais pour Mac

Re,

Pour ce ça intéresse, le dictionnaire sur Mac n'existe pas (les collections si) mais , il existe une alternative qui est le module de classe,
où l'on peut reproduire le processus du dictionnaire et donc faire marché un dictionnaire Excel PC sur un Excel Mac
Merci à Marc-L dont il est l'auteur, pour ce cadeau ;) Voici le lien

Donc en repartant des 2 dictionnaires proposés par Klin89 et Marc-L :

Klin89 :

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
Sub Dico_Kin89_MAC()
Dim a, b, res(), i As Long, j As Long, n As Long, t As Byte
Dim txt As String, dico As New Dictionnaire
    'Set dico = CreateObject("Scripting.Dictionary")
    'dico.CompareMode = 1
    'le 1er tableau en feuil1
    With Sheets("Feuil1").Range("a1").CurrentRegion
        a = .Value: t = 4
        ReDim res(1 To UBound(a, 1), 1 To UBound(a, 2))
        With dico 'CreateObject("Scripting.Dictionary")
           ' .comparemode = 1
            For i = 1 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
                n = n + 1: .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    res(.Item(txt), j) = a(i, j)
                Next
            Next
            'le 2eme tableau en feuil2
            b = Sheets("Feuil2").Range("a1").CurrentRegion.Value
            For i = 2 To UBound(b, 1)
                txt = Join(Array(b(i, 1), b(i, 2)), Chr(2))
                If Not dico.Exists(b(i, 3)) Then
                    t = t + 1: dico(b(i, 3)) = t
                    If UBound(res, 2) < t Then
                        ReDim Preserve res(1 To UBound(res, 1), 1 To UBound(res, 2) + 1)
                        res(1, t) = b(i, 3)
                    End If
                End If
                res(.Item(txt), dico(b(i, 3))) = b(i, 4)
            Next
        End With
    End With
    'la restitution en feuil3
    Application.ScreenUpdating = False
    With Sheets("Feuil3").Range("a1")
        With .Resize(n, t)
            .CurrentRegion.Clear
            .Value = res
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            With .Rows(1)
                .Font.Bold = True
                .BorderAround Weight:=xlThin
                .Interior.ColorIndex = 44
            End With
            .Parent.Activate
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Marc-L :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Demo2DicoMarcL_MAC()
        Dim oDic(1) As New Dictionnaire, C&, L&, R&, V, W
    With Feuil1.Cells(1).CurrentRegion
        C = .Columns.Count + 1
        R = .Rows.Count
        V = .Columns(2).Value
    End With
        For L = 2 To R:  oDic(1).Item(V(L, 1)) = oDic(1).Count + 2:  Next
        V = Feuil2.Cells(1).CurrentRegion.Columns("B:D").Value
    For L = 2 To UBound(V)
        If Not oDic(0).Exists(V(L, 2)) Then oDic(0).Item(V(L, 2)) = oDic(0).Count + 1
    Next
        ReDim W(1 To R, 1 To oDic(0).Count)
        For L = 1 To oDic(0).Count:  W(1, L) = oDic(0).Key(L): Next
    For L = 2 To UBound(V)
        If oDic(1).Exists(V(L, 1)) Then W(oDic(1).Item(V(L, 1)), oDic(0).Item(V(L, 2))) = V(L, 3)
    Next
        Feuil1.Cells(C).Resize(R, oDic(0).Count).Value = W
        Erase oDic, V, W
End Sub

27/11/2016, 21h00
RyuAutodidacte

Re,

Citation:

Envoyé par Ditch3122

Ce fichier va bien me servir pour une tâche particulière mais j'ai aussi une autre demande avec un import supplémentaire de 200.000 lignes et je me demande s'il serait possible de faire tout d'un coup, je suppose que ce serait mieux de créer un nouveau topic.

Dans le cas, où tu utiliserai la macro avec Index :

Code:

V = Application.Index(.Value, Evaluate("ROW(2:" & .Rows.Count & ")"), [{1,2,10,11}])

sur plus de 65536 lignes, attention tu risques d'avoir un problème (reprends moi Marc si j'ai omis qq chose) :
Pour cela lis ce post : VBA Excel Array
27/11/2016, 21h33
Ditch3122

Bonsoir RyuAutodidacte,

Les codes concernés dans ce topic ne concernent que 45.000 lignes max et tout fonctionne très bien en moins de 3 secondes de traitement, c'est magique :)

L'import des 200.000 lignes concerne une demande dans un autre topic, c'est un tri avec affichage du résultat traité par un des codes ci-dessus suivant une date et un lieu choisi.

Didier

Prénom	Id Agent	Ville	Langue
Alain	111	Liège	FR
Marc	112	Charleroi	FR
André	123	Namur	FR
Henry	124	Namur	FR

Prénom	Id Agent	Skill	Level
Alain	111	H_REP	4
Alain	111	T_SEP	3
Alain	111	R_TEC	4
Marc	112	H_REP	4
Marc	112	T_SEP	3
André	123	R_TEC	4
André	123	P_BOC	3
Henry	124	T_SEP	2
Henry	124	P_BOC	4

Nom	Id_Tech
Marc	111
Marc, zone2	111
Marc, Zone3	111
Eric	122