Discussion :

[Blondain]

Bonjour,

Je sollicite votre aide afin de m'eclairer sur une maniere de proceder face à un probleme que je rencontre

Dans une feuille intitulée "ANALYSE_WEEK" j'ai mes données presentées de la façon suivante (ces donnees viennent d'un copier coller d'un tableau croisé dynamique) :

Produit > colonne A
Taille >Colonne C
Note > Colonne X (les notes vont de A à E, quand il y a un - c'est que la note n'est pas suffisante pour etre prise en compte)
J'aimerais pouvoir conserver l'organisation de mes colonnes (entre col C et X il y a une colonne par N°de semaine, et des formules de calcul)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Produit  Taille  Note
 
AAA       100   B
AAA       200   A
AAA       220   E
AAA       300   E
BBB        100   -
BBB        150   D
BBB        155  D
DDD        200  C
DDD        220  D
DDD        300  D

J'aimerais regrouper ces donnees dans une nouvelle feuille intitulée "SYNTHESE" presentée de la maniere suivante :
(en gros ce serait comme un tableau dynamique sauf qu'aux intersections Lignes/colonnes je souhaite afficher toutes les valeurs correspondantes au lieu d'un calcul)

Code :

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

1
2
3
4
5
 
Produit    A           B           C         D              E
AAA       200       100                                   220 , 300
BBB                                           150,155
DDD                                200      220,300

J'ai trouvé sur code mais je n'arrive pas à :
- Garder l'organisation des colonnes (je suis obligé de copier dans nouvelles feuilles et reorganiser afin d'avoir des colonnes contigues)
- ecrire dans une meme cellule toutes mes valeurs correspondant à l'intersection produit/note . Ca ne met que la valeur la plus grande correspodant à l'intersection par exemple, pour le tableau ci dessus ca met la valeur 300 à l'intersection porduit AAA note E alors que je souhaiterais voir afficher 220 , 300

Voici le code trouvé si ça peut aider

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
Option Explicit
 
Sub Tableau()
    ' réorganise sous forme de tableau dans une nouvelle feuille des données fournies sur 3 colonnes :
    ' colonne A : nom de ligne
    ' Colonne B : nom de colonne
    ' Colonne C : data
    ' la feuille contenant les données doit etre active avant de lancer la macro
    Dim data()
    Dim col()
    Dim lig()
    Dim nblig As Long, i As Long, j As Long, k As Long
    Dim sh As Worksheet
    Set sh = ActiveSheet
    ' créer feuille Tableau (la supprimer avant si existante)
    Application.DisplayAlerts = False
    On Error GoTo creer
    Sheets("Tableau").Activate
    Sheets("Tableau").Delete
    Application.DisplayAlerts = True
creer:
    Sheets.Add.Name = "Tableau"
    '
    sh.Activate
    ' préparer tableau
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
    col = Range("AA2:AA" & [AA65536].End(xlUp).Row)
    Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AB1"), Unique:=True
    lig = Range("AB2:AB" & [AB65536].End(xlUp).Row)
    'coller noms col
    Range([AA2], [AA2].End(xlDown)).Copy
    Sheets("Tableau").Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=False
    'colle noms lig
    Range([AB2], [AB2].End(xlDown)).Copy
    Sheets("Tableau").Range("B1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    ' supprimer colonnes temporaires
    Columns("AA:AB").Delete Shift:=xlToLeft
    ' remplir tableau
    data = Range("A2:C" & [A65536].End(xlUp).Row)
    For i = 1 To UBound(data)
        j = 1
        While data(i, 1) <> col(j, 1)
            j = j + 1
        Wend
        k = 1
        While data(i, 2) <> lig(k, 1)
            k = k + 1
        Wend
        Worksheets("Tableau").Cells(j + 1, k + 1).Value = data(i + 1, 3)
    Next i
End Sub

[mercatog]

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
Sub Test()
Dim Sh As Worksheet
Dim ColProd As New Collection, ColNote As New Collection
Dim c As Range
Dim LastLig As Long, i As Long
Dim j As Integer, nbP As Integer
Dim Res As String
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("ANALYSE_WEEK")
    .AutoFilterMode = False
    LastLig = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastLig
        On Error Resume Next
        ColProd.Add .Range("A" & i).Value, .Range("A" & i).Value
        If .Range("X" & i).Value <> "-" Then ColNote.Add .Range("X" & i).Value, .Range("X" & i).Value
        On Error GoTo 0
    Next i
    On Error Resume Next
    Sheets("Tableau").Delete
    On Error GoTo 0
    Set Sh = Sheets.Add(After:=Sheets("ANALYSE_WEEK"))
    Sh.Name = "Tableau"
    For j = 1 To ColNote.Count
        Sh.Cells(1, j + 1).Value = ColNote(j)
    Next j
    For i = 1 To ColProd.Count
        Sh.Cells(i + 1, 1).Value = ColProd(i)
        .Range("A1:X" & LastLig).AutoFilter Field:=1, Criteria1:=ColProd(i)
        For j = 1 To ColNote.Count
            .Range("A1:X" & LastLig).AutoFilter Field:=24, Criteria1:=ColNote(j)
            If .Range("A1:A" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then
                Res = ""
                For Each c In .Range("C2:C" & LastLig).SpecialCells(xlCellTypeVisible)
                    Res = Res & ", " & c.Value
                Next c
                Sh.Cells(i + 1, j + 1).Value = Mid(Res, 2)
            End If
        Next j
        .AutoFilterMode = False
    Next i
End With
Sh.Range(Sh.Cells(2, 1), Sh.Cells(ColProd.Count + 1, ColNote.Count + 1)).Sort key1:=Sh.Cells(2, 1), Header:=xlNo
Sh.Range(Sh.Cells(1, 2), Sh.Cells(ColProd.Count + 1, ColNote.Count + 1)).Sort key1:=Sh.Cells(1, 2), Header:=xlNo, Orientation:=xlSortRows
Application.DisplayAlerts = True
End Sub