Discussion :

[Ditch3122]

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

[Marc-L]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 pour chaque message ayant aidé puis sur pour clore cette discussion …

_________________________________________________________________________________________________________

Je suis Paris, Nice, Bruxelles, Charlie, …

[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

[RyuAutodidacte]

Bonsoir,

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

je t'ai mis

[Klin89]

Bonsoir Marc-L, RyuAutodidacte, Ditch3122

Avec 2 dictionnaires :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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

[Marc-L]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 si vous appréciez ce code !