Creer un tableau avec donnees concatenée à l'intersection

blondain

XLDnaute Nouveau
Bonjour,

Mes connaissances en excel etant limitée, 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:
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:
Produit    A           B           C         D              E
AAA       200       100                                 220,300
BBB                                           150,155
DDD                                200      220,300

J'ai trouvé un code mais je n'arrive pas à :
- Garder l'organisation des colonnes à traiter (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

Ci dessous le code que j'ai trouvé.
Code:
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
Pensez vous qu'il puisse etre adapté à mon pb ou faut il que je procede d'une autre maniere ?


Merci pour votre aide
 

PMO2

XLDnaute Accro
Re : Creer un tableau avec donnees concatenée à l'intersection

Bonjour,

Une piste avec le code suivant à copier dans un module standard

Code:
'### Constante à adapter ###
Const FEUILLE_SOURCE As String = "ANALYSE_WEEK"
'###########################

Sub aa()
Dim S As Worksheet
Dim DICO As Object
Dim var
Dim Notes
Dim i&
Dim j&
Dim k&
Dim A$
Dim T()
Dim T2()
Notes = Array("A", "B", "C", "D", "E")
Set S = Sheets(FEUILLE_SOURCE)
var = S.Range("a2:x" & S.[a65536].End(xlUp).Row & "")
Set DICO = CreateObject("Scripting.Dictionary")
For i& = 1 To UBound(var, 1)
  A$ = UCase(var(i&, 1))
  If Not DICO.Exists(A$) Then
    DICO.Add A$, A$
    ReDim Preserve T(1 To DICO.Count)
    T(DICO.Count) = A$
  End If
Next i&
ReDim T2(1 To UBound(T), 1 To UBound(Notes) + 2)
For j& = 1 To UBound(T)
  T2(j&, 1) = T(j&)
Next j&
For i& = 1 To UBound(var, 1)
  For j& = 1 To UBound(T)
    If UCase(var(i&, 1)) = T(j&) Then
      For k& = 0 To UBound(Notes)
        If UCase(var(i&, 24)) = UCase(Notes(k&)) Then
          If T2(j&, k& + 2) = "" Then
            T2(j&, k& + 2) = var(i&, 3)
          Else
            T2(j&, k& + 2) = T2(j&, k& + 2) & "_" & var(i&, 3)
          End If
        End If
      Next k&
    End If
  Next j&
Next i&
Sheets.Add after:=Sheets(S.Index)
Set S = ActiveSheet
S.Range(S.Cells(2, 1), S.Cells(UBound(T) + 1, UBound(Notes) + 2)) = T2
S.[a1] = "Produit"
S.Range(S.Cells(1, 2), S.Cells(1, UBound(Notes) + 2)) = Notes
End Sub


Cordialement.

PMO
Patrick Morange
 

blondain

XLDnaute Nouveau
Re : Creer un tableau avec donnees concatenée à l'intersection

Bonjour

Et bien un enorme merci !!
Je viens d'essayer, c'est tres precisement ce que je souhaitais faire.

Le code etant a des années lumieres de mes connaissance, je suis incapable d'en comprendre le fonctionnement.
Puis je me permettre d'abuser d'avantage de votre temps en vous demandant quelques explications ou commentaires dans le code ?
J'aimerais etre capable d'adapter si besoin ou reutiliser pour d'autres cas.

Encore merci pour votre aide precieuse.
 

PMO2

XLDnaute Accro
Re : Creer un tableau avec donnees concatenée à l'intersection

Bonjour,

J'ai ajouté quelques commentaires au code qui reste inchangé

Code:
'### Constante à adapter ###
Const FEUILLE_SOURCE As String = "ANALYSE_WEEK"
'###########################

Sub aa()
Dim S As Worksheet
Dim DICO As Object
Dim var As Variant
Dim Notes As Variant
Dim i&
Dim j&
Dim k&
Dim A$
Dim T()
Dim T2()

'--- les différentes données possibles de la colonne X (24ème colonne)
Notes = Array("A", "B", "C", "D", "E")

'--- la plage "A2:Xdernière ligne colonne A" est mise dans un Variant (tableau à 2 dimensions)
Set S = Sheets(FEUILLE_SOURCE)
var = S.Range("a2:x" & S.[a65536].End(xlUp).Row & "")

'--- recherche en colonne 1 du tableau de chaque occurence différente
'--- (utilisation d'un dictionnaire  Windows Scipt Host)
Set DICO = CreateObject("Scripting.Dictionary")
For i& = 1 To UBound(var, 1)
  A$ = UCase(var(i&, 1))
  If Not DICO.Exists(A$) Then
    DICO.Add A$, A$
    ReDim Preserve T(1 To DICO.Count)
    T(DICO.Count) = A$
  End If
Next i&

'--- redimensionne le tableau des résultats
ReDim T2(1 To UBound(T), 1 To UBound(Notes) + 2)

'--- inscription des occurences en colonne 1 du tableau de résultats
For j& = 1 To UBound(T)
  T2(j&, 1) = T(j&)
Next j&

'--- pour chaque ligne du tableau source (var)
For i& = 1 To UBound(var, 1)
  '--- pour chaque occurence du tableau T (dico)
  For j& = 1 To UBound(T)
    '--- si correspondance colonne A et dico
    If UCase(var(i&, 1)) = T(j&) Then
      '--- pour chaque Notes
      For k& = 0 To UBound(Notes)
        '--- si correspondance colonne X et Notes
        If UCase(var(i&, 24)) = UCase(Notes(k&)) Then
          '--- si tableau résultats (T2) non renseigné
          If T2(j&, k& + 2) = "" Then
            T2(j&, k& + 2) = var(i&, 3)
          '--- sinon concaténation
          Else
            T2(j&, k& + 2) = T2(j&, k& + 2) & "_" & var(i&, 3)
          End If
        End If
      Next k&
    End If
  Next j&
Next i&

'--- création nouvelle feuille
Sheets.Add after:=Sheets(S.Index)
Set S = ActiveSheet

'--- dimensionne la plage et y inscrit les résultats
S.Range(S.Cells(2, 1), S.Cells(UBound(T) + 1, UBound(Notes) + 2)) = T2

'--- titres de la 1ère ligne
S.[a1] = "Produit"
S.Range(S.Cells(1, 2), S.Cells(1, UBound(Notes) + 2)) = Notes
End Sub

Cordialement.

PMO
Patrick Morange
 

Discussions similaires

Statistiques des forums

Discussions
311 713
Messages
2 081 806
Membres
101 819
dernier inscrit
lukumubarth