tableau à inverser

Le
Patrick
Bonjour,

Je dois inverser/modifier un gros tableau suivant l'exemple dont le lien
est ci-dessous..

Peut on me donner un coup de main (sans formule mais par VBA tableau ou
dictionnaire)?

Un + serait de commenter les lignes :)

Merci

http://www.cjoint.com/c/FLjqcF8qIVx
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
?K?
Le #26420107
Bonjour
D'après Patrick
...
Je dois inverser/modifier un gros tableau suivant l'exemple dont le lien
est ci-dessous..
Peut on me donner un coup de main (sans formule mais par VBA tableau ou
dictionnaire)?
Un + serait de commenter les lignes :)
http://www.cjoint.com/c/FLjqcF8qIVx ...

rigolo comme problème :-)
voilà un exemple qui fonctionne sur ton tableau et il suffit de changer
quelques constantes pour que ça fonctionne sur un tableau plus grand
----------------------------------------
Sub inverser()
' attention c'est sensible à la casse et aux espaces
' utiliser au besoin trim et Lcase
' j'ai rajouté une colonne pour voir : la symétrie n'est pas nécessaire
' pour les dimensions du tableau
' mais l'unicité des valeurs par colonne est nécessaire dans le tableau
' de départ
Dim i0 As Integer, j0 As Integer, i1 As Integer, j1 As Integer
Dim verti, hori ' seront des tableaux je laisse en variant
' i0 et j0 emplacement du premier tableau
' i1 et j1 : emplacement du deuxième - ils sont sur la même feuille
i0 = 3: j0 = 1
i1 = 22: j1 = 1
' i1 doit être plus grand que 20 utilisé pour tester le nombre de
' colonnes plus bas
' ou alors j1 plus grand que 10 utilisé pour nombre de lignes
Set valsverti = CreateObject("Scripting.Dictionary")
' liste des noms horizontaux (verticaux tableau 2)
Set valshori = CreateObject("Scripting.Dictionary")
' liste des noms trouvés dans la 2ème colonne (horizontaux tableau 2)
For j = 1 To Cells(3, 10).End(xlToLeft).Column - j0
' si moins de 10 colonnes en tout - ou remplacer par nombre de colonnes
' le test sur l'existence évite l'erreur à la valeur vide
' le test sur l'existence évite l'erreur à la valeur vide
If Not valsverti.exists(Cells(i0, j + j0).Value) Then
' mais il risque de laisser un trou si doublons
valsverti.Add Cells(i0, j + j0).Value, j
End If
Next
For i = 1 To Cells(20, 1).End(xlUp).Row - i0
' si moins de 20 lignes en tout - ou remplacer par nombre de lignes
' le test sur l'existence évite l'erreur à la valeur vide
If Not valshori.exists(Cells(i + i0, j0 + 1).Value) Then
' mais il risque de laisser un trou si doublons
valshori.Add Cells(i + i0, j0 + 1).Value, i
' liste des nom trouvés dans la deuxième colonne (horizontaux tableau
2)
End If
Next
verti = valsverti.keys
' liste des noms horizontaux (verticaux tableau 2)
' verti(i) donne le ième nom
hori = valshori.keys
' liste des nom trouvés dans la 2ème colonne (horizontaux tableau 2)
For i = 0 To valsverti.Count - 1
Cells(valsverti(verti(i)) + i1, j0).Value = verti(i)
Next
For j = 0 To valshori.Count - 1
Cells(i1, valshori(hori(j)) + j0).Value = hori(j)
Next
For i = 1 To valshori.Count
For j = 1 To valsverti.Count
'en parcourant le tableau du haut
' cells(i+i0,j+j0).value donne valshori son rang est
' valshori(cells(i+i0,j+j0).value) auquel j'ajouterai j0
' cells(i+i0,j0).value me donne valsvals et je l'écrirai en bas
' cells (i0, j+j0).value me donne valsverti son rang est
' valsverti(cells(i0,j+j0).value auquel j'ajouterai i1
Cells(valsverti(Cells(i0, j + j0).Value) + i1, valshori(Cells(i + i0, j
+ j0).Value) + j0).Value = Cells(i + i0, j0).Value
Next
Next
End Sub
-------------------------------
cdlt
--
-
?K?
Le #26420108
Bonjour
D'après Patrick
...
Je dois inverser/modifier un gros tableau suivant l'exemple dont le
lien est ci-dessous..
Peut on me donner un coup de main (sans formule mais par VBA tableau ou
dictionnaire)?
Un + serait de commenter les lignes
http://www.cjoint.com/c/FLjqcF8qIVx ...
rigolo comme problème
voilà un exemple qui fonctionne sur ton tableau et il suffit de changer
quelques constantes pour que ça fonctionne sur un tableau plus grand
----------------------------------------
Sub inverser()
' attention c'est sensible à la casse et aux espaces
' utiliser au besoin trim et Lcase
' j'ai rajouté une colonne pour voir : la symétrie n'est pas nécessaire
' pour les dimensions du tableau
' mais l'unicité des valeurs par colonne est nécessaire dans le tableau
de départ
Dim i0 As Integer, j0 As Integer, i1 As Integer, j1 As Integer
Dim verti, hori ' seront des tableaux je laisse en variant
' i0 et j0 emplacement du premier tableau
' i1 et j1 : emplacement du deuxième - ils sont sur la même feuille
i0 = 3: j0 = 1
i1 = 22: j1 = 4
' i1 doit être plus grand que 20 utilisé pour tester le nombre de
' colonnes plus bas
' ou alors j1 plus grand que 10 utilisé pour nombre de lignes
Set valsverti = CreateObject("Scripting.Dictionary")
' liste des noms horizontaux (verticaux tableau 2)
Set valshori = CreateObject("Scripting.Dictionary")
' liste des noms trouvés dans la 2ème colonne (horizontaux tableau 2)
For j = 1 To Cells(3, 10).End(xlToLeft).Column - j0
' si moins de 10 colonnes en tout - ou remplacer par nombre de colonnes
' le test sur l'existence évite l'erreur à la valeur vide
' mais il risque de laisser un trou si doublons
If Not valsverti.exists(Cells(i0, j + j0).Value) Then
valsverti.Add Cells(i0, j + j0).Value, j
End If
Next
For i = 1 To Cells(20, 1).End(xlUp).Row - i0
' si moins de 20 lignes en tout - ou remplacer par nombre de lignes
' le test sur l'existence évite l'erreur à la valeur vide
' mais il risque de laisser un trou si doublons
If Not valshori.exists(Cells(i + i0, j0 + 1).Value) Then
valshori.Add Cells(i + i0, j0 + 1).Value, i
End If
Next
verti = valsverti.keys
' liste des noms horizontaux (verticaux tableau 2)
' verti(i) donne le ième nom
hori = valshori.keys
' liste des nom trouvés dans la 2ème colonne (horizontaux tableau 2)
Cells(valsverti(verti(i)) + i1, j1).Value = verti(i)
Next
For j = 0 To valshori.Count - 1
Cells(i1, valshori(hori(j)) + j1).Value = hori(j)
Next
For i = 1 To valshori.Count
For j = 1 To valsverti.Count
'en parcourant le tableau du haut
' cells(i+i0,j+j0).value donne valshori son rang est
' valshori(cells(i+i0,j+j0).value) auquel j'ajouterai j1
' cells(i+i0,j0).value me donne valsvals et je l'écrirai en bas
' cells (i0, j+j0).value me donne valsverti son rang est
' valsverti(cells(i0,j+j0).value auquel j'ajouterai i1
Cells(valsverti(Cells(i0, j + j0).Value) + i1, valshori(Cells(i +
i0, j + j0).Value) + j1).Value _
= Cells(i + i0, j0).Value
Next
Next
End Sub
-------------------------------
cdlt
--
-
?K?
Le #26420110
hello
D'après Patrick
Bonjour,
Je dois inverser/modifier un gros tableau suivant l'exemple dont le lien est
ci-dessous..
http://www.cjoint.com/c/FLjqcF8qIVx

variante : cette fois on met le résultat sur une autre feuille
c'est mieux je trouve si letableau est gros
-----------------
Sub inverser(f1 As String, f2 As String)
'f1 feuille de départ, f2 feuille arrivée
' attention c'est sensible à la casse et aux espaces
' utiliser au besoin trim et Lcase
' j'ai rajouté une colonne pour voir : la symétrie n'est pas nécessaire
' pour les dimensions du tableau
' mais l'unicité des valeurs par colonne est nécessaire dans le tableau
de départ
Dim i0 As Integer, j0 As Integer, i1 As Integer, j1 As Integer
Dim verti, hori ' seront des tableaux je laisse en variant
' i0 et j0 emplacement du premier tableau sur f1
' i1 et j1 : emplacement du deuxième sur f2
i0 = 3: j0 = 1
i1 = 3: j1 = 1
' pas de problème si f1 et f2 sont différents sinon attention au
recouvrement
With Sheets(f1)
Set valsverti = CreateObject("Scripting.Dictionary")
' liste des noms horizontaux (verticaux tableau 2)
Set valshori = CreateObject("Scripting.Dictionary")
' liste des noms trouvés dans la 2ème colonne (horizontaux tableau 2)
For j = 1 To .Cells(3, 100).End(xlToLeft).Column - j0
' si moins de 100 colonnes en tout - ou remplacer par nombre de
colonnes
' le test sur l'existence évite l'erreur à la valeur vide
' mais il risque de laisser un trou si doublons
If Not valsverti.exists(.Cells(i0, j + j0).Value) Then
valsverti.Add .Cells(i0, j + j0).Value, j
End If
Next
For i = 1 To .Cells(200, 1).End(xlUp).Row - i0
' si moins de 200 lignes en tout - ou remplacer par nombre de lignes
' le test sur l'existence évite l'erreur à la valeur vide
' mais il risque de laisser un trou si doublons
If Not valshori.exists(.Cells(i + i0, j0 + 1).Value) Then
valshori.Add .Cells(i + i0, j0 + 1).Value, i
End If
Next
verti = valsverti.keys
' liste des noms horizontaux (verticaux tableau 2)
' verti(i) donne le ième nom
hori = valshori.keys
' liste des nom trouvés dans la 2ème colonne (horizontaux tableau 2)
For i = 0 To valsverti.Count - 1
Sheets(f2).Cells(valsverti(verti(i)) + i1, j1).Value = verti(i)
Next
For j = 0 To valshori.Count - 1
Sheets(f2).Cells(i1, valshori(hori(j)) + j1).Value = hori(j)
Next
For i = 1 To valshori.Count
For j = 1 To valsverti.Count
'en parcourant le tableau du haut
' cells(i+i0,j+j0).value donne valshori son rang est
' valshori(cells(i+i0,j+j0).value) auquel j'ajouterai j1
' cells(i+i0,j0).value me donne valsvals et je l'écrirai en bas
' cells (i0, j+j0).value me donne valsverti son rang est
' valsverti(cells(i0,j+j0).value auquel j'ajouterai i1
Sheets(f2).Cells(valsverti(.Cells(i0, j + j0).Value) + i1,
valshori(.Cells(i + i0, j + j0).Value) + j1).Value _
= .Cells(i + i0, j0).Value
Next
Next
End With
End Sub
Sub test()
Call inverser("avant", "apres")
End Sub
-------------
cdlt
--
-
PatrIck
Le #26420218
Le vendredi 9 décembre 2016 17:06:03 UTC+1, Patrick a écrit  :
Bonjour,

Bonjour,
merci, je regarde ça dans la semaine :)
Patrick
Je dois inverser/modifier un gros tableau suivant l'exemple dont le lien
est ci-dessous..
Peut on me donner un coup de main (sans formule mais par VBA tableau ou
dictionnaire)?
Un + serait de commenter les lignes :)
Merci
http://www.cjoint.com/c/FLjqcF8qIVx
isabelle
Le #26420240
bonjour Patrick,
mon exemple suppose que le tableau est sur la Feuil1 et commence à la cellule A1
le résultat est mit sur la Feuil2
Sub Test_inverser_tableau()
Dim Dico1 As New Scripting.Dictionary
Dim Dico2 As New Scripting.Dictionary
Dim c As Range
Dim lign1 As Long, coln1 As Integer
Dim lign2 As Long, coln2 As Integer
Set f1 = Sheets("Feuil1")
Set f2 = Sheets("Feuil2")
f2.Range("A:F").ClearContents
' grandeur du tableau original
With f1
lign1 = .Cells(.Rows.Count, 1).End(xlUp).Row
coln1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set plg = .Range(.Cells(2, 2), .Cells(lign1, coln1))
End With
' ajout de la Clé1(10, 20, 30....) (sans doublon)dans le Dico1
For i = 2 To coln1
Cle1 = f1.Cells(1, i)
If Not Dico1.Exists(Cle1) Then Dico1.Add Cle1, i
Next
'transpose le dico1 (10, 20, 30....) dans la "Feuil2"
f2.Range("A2").Resize(Dico1.Count, 1) = Application.Transpose(Dico1.Keys)
' ajout de la Clé2(G01, G02, G03....) (sans doublon)dans le Dico2
For Each c In plg
If Not Dico2.Exists(c.Value) Then Dico2.Add c.Value, i
Next
'transpose le dico1 (G01, G02, G03....) dans la "Feuil2"
f2.Range("B1").Resize(1, Dico2.Count) =
Application.Transpose(Application.Transpose(Dico2.Keys))
' inscrire les noms
For Each c In plg
n1 = f1.Cells(1, c.Column) ' (10, 20, 30....)
n2 = f1.Cells(c.Row, 1) ' (Pierre, Paul....)
lign2 = Application.Match(n1, f1.Rows(1), 0) 'ligne de f2
coln2 = Application.Match(c, f2.Rows(1), 0) 'colonne de f2
f2.Cells(lign2, coln2) = n2
Next
Set Dico1 = Nothing
Set Dico2 = Nothing
End Sub
isabelle
Le 2016-12-09 à 11:06, Patrick a écrit :
Bonjour,
Je dois inverser/modifier un gros tableau suivant l'exemple dont le lien est
ci-dessous..
Peut on me donner un coup de main (sans formule mais par VBA tableau ou
dictionnaire)?
Un + serait de commenter les lignes :)
Merci
http://www.cjoint.com/c/FLjqcF8qIVx
isabelle
Le #26420242
un peu plus court avec une boucle en moins,
Sub Test_inverser_tableau2()
Dim Dico1 As New Scripting.Dictionary
Dim Dico2 As New Scripting.Dictionary
Dim c As Range
Dim lign1 As Long, coln1 As Integer
Dim lign2 As Long, coln2 As Integer
Dim i As Integer
Set f1 = Sheets("Feuil1")
Set f2 = Sheets("Feuil2")
f2.Range("A:F").ClearContents
' grandeur du tableau original
With f1
lign1 = .Cells(.Rows.Count, 1).End(xlUp).Row
coln1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set plg = .Range(.Cells(2, 2), .Cells(lign1, coln1))
End With
' ajout de la Clé1(10, 20, 30....) (sans doublon)dans le Dico1
For i = 2 To coln1
Cle1 = f1.Cells(1, i)
If Not Dico1.Exists(Cle1) Then Dico1.Add Cle1, i
Next
'transpose le dico1 (10, 20, 30....) dans la "Feuil2"
f2.Range("A2").Resize(Dico1.Count, 1) = Application.Transpose(Dico1.Keys)
' ajout de la Clé2(G01, G02, G03....) (sans doublon)dans le Dico2
For Each c In plg
If Not Dico2.Exists(c.Value) Then Dico2.Add c.Value, i
'transpose le dico1 (G01, G02, G03....) dans la "Feuil2"
f2.Range("B1").Resize(1, Dico2.Count) =
Application.Transpose(Application.Transpose(Dico2.Keys))
'inscrire les noms
n1 = f1.Cells(1, c.Column) ' (10, 20, 30....)
n2 = f1.Cells(c.Row, 1) ' (Pierre, Paul....)
lign2 = Application.Match(n1, f1.Rows(1), 0) 'ligne de f2
coln2 = Application.Match(c, f2.Rows(1), 0) 'colonne de f2
f2.Cells(lign2, coln2) = n2
Next
Set Dico1 = Nothing
Set Dico2 = Nothing
End Sub
isabelle
isabelle
Le #26420247
une autre plus rapide... en une seul boucle
http://www.cjoint.com/c/FLmbD51INxa
Sub Test_inverser_tableau1()
Dim Dico1 As New Scripting.Dictionary, Dico2 As New Scripting.Dictionary
Dim lign1 As Long, coln1 As Integer, lign2 As Long, coln2 As Integer
Dim c As Range, i As Integer
Set f1 = Sheets("Feuil1")
Set f2 = Sheets("Feuil2")
f2.Cells.ClearContents
lign1 = f1.Cells(Rows.Count, 1).End(xlUp).Row
coln1 = f1.Cells(1, Columns.Count).End(xlToLeft).Column
Set plg = f1.Range(Cells(2, 2).Address, Cells(lign1, coln1).Address) 'tableau
original
For Each c In plg
If Not Dico1.Exists(c.Row) Then Dico1.Add c.Row, f1.Cells(1, c.Row) 'ajout
sur dico1(10, 20, 30....)
If Not Dico2.Exists(c.Value) Then Dico2.Add c.Value, 1 'ajout
sur dico2(G01, G02, G03....)
f2.Range("B1").Resize(1, Dico2.Count) =
Application.Transpose(Application.Transpose(Dico2.Keys))
lign2 = Application.Match(f1.Cells(1, c.Column), f1.Rows(1), 0) 'ligne de
f2 (10, 20, 30....)
coln2 = Application.Match(c, f2.Rows(1), 0) 'colonne
de f2 (G01, G02, G03....)
f2.Cells(lign2, coln2) = f1.Cells(c.Row, 1) ' inscrire les noms(Pierre,
Paul....)
Next
f2.Range("A2").Resize(Dico1.Count, 1) = Application.Transpose(Dico1.Items)
'copie de(10, 20, 30....)
Set Dico1 = Nothing
Set Dico2 = Nothing
End Sub
isabelle
PatrIck
Le #26420252
Bonjour Isabelle,
merci, j'étais arrivé au 2/3 de la solution et je ne trouvais pas de solution avec les lignes application.match !
Super !
Il me reste à adapter parce que il peut y avoir 2 noms dans un mê me groupe, mais je pense avoir réussi :)
ps:
Je tente de mettre ça dans un tableau et puis coller le tableau au lie u d'écrire par une boucle dans les cellules...
J'ignore comment déclarer, redimensionner ce tableau (malgré les exemples trouvés) et le coller en 2e ligne, 2e colonne de la feuille c ible (f2)
Si tu as 5 minutes :)
Patrick
ps: Ce tableau risque de servir quelques fois ! Génial !
Le vendredi 9 décembre 2016 17:06:03 UTC+1, Patrick a écrit  :
Bonjour,
Je dois inverser/modifier un gros tableau suivant l'exemple dont le lien
est ci-dessous..
Peut on me donner un coup de main (sans formule mais par VBA tableau ou
dictionnaire)?
Un + serait de commenter les lignes :)
Merci
http://www.cjoint.com/c/FLjqcF8qIVx
isabelle
Le #26420297
tu pourrais remplacer la ligne
f2.Cells(lign2, coln2) = f1.Cells(c.Row, 1)
par
f2.Cells(lign2, coln2) = f2.Cells(lign2, coln2) & " - " & f1.Cells(c.Row, 1)
isabelle
Le 2016-12-12 à 01:12, PatrIck a écrit :
Super !
Il me reste à adapter parce que il peut y avoir 2 noms dans un même groupe, mais je pense avoir réussi :)
PatrIck
Le #26420373
Le vendredi 9 décembre 2016 17:06:03 UTC+1, Patrick a écrit  :
Bonjour,
Je dois inverser/modifier un gros tableau suivant l'exemple dont le lien
est ci-dessous..
Peut on me donner un coup de main (sans formule mais par VBA tableau ou
dictionnaire)?
Un + serait de commenter les lignes :)
Merci
http://www.cjoint.com/c/FLjqcF8qIVx

Merci Isabelle !
Publicité
Poster une réponse
Anonyme