Algo transposition tableau VBA

richert90 · 23 Décembre 2013

Bonjour,

J'ai un tableau initial (P.J) que je souhaite transposer dans un 2ième onglet d'Excel.
Je suis bloqué au niveau de l'algorithme qui me permet de transposer le tableau
L'onglet 3 d'Excel est l'aperçu du tableau final souhaité.

Merci de m'aider pour trouver comment faire...
(Vous pouvez voir le peu que j'ai fait en VBA pour transposer le tableau dans le module "transposition")

Merci d'avance

pierrejean · 23 Décembre 2013

Re : Algo transposition tableau VBA

Bonjour richert90

Petite question :Comment extrait-on le Board ?
par exemple a partir de

Gr1 Avg

Gr1B02

richert90 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Bonjour pierrejean

En fait je ne m’intéresse qu'aux colonnes avec Gr1B01, Gr1B02, ... Gr2B01 etc... et Gr1B01 max etc...
Gr --> Groupe
B --> Board
Gr1B01 : Groupe 1 et Board 1
Les colonnes GR1 Avg, Gr2 Avg,etc... je les laisses de côté pour le moment

PS: le nombre de groupe et de board par groupe est variable, ici Groupe=3 et board=11 mais ça peut être différent d'où la difficulté de l'algo.

ROGER2327 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Bonjour à tous.

Un essai :

VB:

Sub transposition_tableau()
Dim i&, j&, k&, v$, bs, bt, x, y, Champs(), b(), m(), Cel As Range

  Champs = Feuil1.[A1].Resize(1, Feuil1.[A1].End(xlToRight).Column - 2).Offset(0, 2).Value
  m = Array()
  b = Array()

  For i = 1 To UBound(Champs, 2)
    If Champs(1, i) Like "Gr*B* Max" Then
      ReDim Preserve m(UBound(m) + 1)
      m(UBound(m)) = Array(i, Champs(1, i))
    End If
  Next

  For i = 0 To UBound(m)
    v = Left$(m(i)(1), Len(m(i)(1)) - 4)
    For j = 1 To UBound(Champs, 2)
      If v = Champs(1, j) Then
        ReDim Preserve b(UBound(b) + 1)
        b(UBound(b)) = Array(j, Champs(1, j))
      End If
    Next
  Next

  With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With

  Feuil2.[A1].CurrentRegion.Offset(1).ClearContents
  For Each Cel In Feuil1.[A1].Resize(Feuil1.[A1].End(xlDown).Row - 1, 1).Offset(1).Cells
    bt = Cel.Value: bs = Cel.Offset(, 1).Value
    For i = 0 To UBound(b)
      x = Split(b(i)(1), "r")
      y = Split(x(1), "B")
      ReDim Preserve y(6)
      y(2) = bt: y(3) = bs
      y(4) = Cel.Offset(, b(i)(0) + 1).Value
      y(5) = Cel.Offset(, m(i)(0) + 1).Value
      k = k + 1
      Feuil2.[A1].Resize(1, 6).Offset(k).Value = y
    Next
  Next

  Set Cel = [A1].Resize(k, 6)
  With Feuil2.Sort
    With .SortFields
      .Clear
      .Add Key:=Cel.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
      .Add Key:=Cel.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    End With
    .SetRange Cel.Cells
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With

  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With

End Sub

C'est brut de fonderie : si ça convient, on pourra (peut-être) perfectionner la chose.

Bonne soirée.

ℝOGER2327
#7079

Lundi 23 Sable 141 (Sainte Viole, vierge et martyre - fête Suprême Quarte)
3 Nivôse An CCXXII, 6,8654h - bitume
2013-W52-1T16:28:37Z

Paf · 23 Décembre 2013

Re : Algo transposition tableau VBA

Bonjour à tous

une autre version:

Code:

Private Sub Trans()
Dim TAblo, Tablo2
Dim NbElement As Integer, NbTablo2 As Integer
Dim x

x = 0
NbElement = Worksheets("dataBase").Range("A" & Rows.Count).End(xlUp).Row - 1

NbTablo2 = (NbElement) * 33
ReDim Tablo2(NbTablo2, 6)
TAblo =Worksheets("dataBase").Range("A1:BV6")

For i = 5 To UBound(TAblo, 2) Step 24
    For j = 0 To 21 Step 2
        For k = 2 To NbElement + 1
            Tablo2(x, 0) = Mid(TAblo(1, i + j), 3, 1)
            Tablo2(x, 1) = Right(TAblo(1, i + j), Len(TAblo(1, i + j)) - 4)
            Tablo2(x, 2) = TAblo(k, 1)
            Tablo2(x, 3) = TAblo(k, 2)
            Tablo2(x, 4) = TAblo(k, i + j)
            Tablo2(x, 5) = TAblo(k, i + j + 1)
            x = x + 1
        Next
    Next
Next
Worksheets("Aperçu").[A2].Resize(UBound(Tablo2, 1), UBound(Tablo2, 2)).Value2 = Tablo2
End Sub

avec des restrictions :
à adapter si le nombre de groupe augmente
à modifier si le nombre de board par groupe change

A+

richert90 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Bonjour ROGER2327,Paf

Merci pour vos réponses!!

Je me suis penché sur le code de ROGER2327 pour le moment et ça marche parfaitement!
J'ai juste 2 questions:
- Si le nombre de groupe et de carte change, ce code est-il toujours bon? ou faut-il modifier des choses ?
- Comment tu arrives à sortir ce code pareil? 😱 j'aurais jamais trouvé, c'est sur..

Paf, je vais regarder ce que tu m'a proposé 🙂

Merci beaucoup à vous en tout cas d'avoir pris le temps de m'aider 😉. C'était mon cadeau de Noel 😛

Paf · 23 Décembre 2013

Re : Algo transposition tableau VBA

Re,

juste une petite erreur de feuille en fin de code:
au lieu de
Worksheets("Aperçu").[A2].Resize(UBound(Tablo2, 1), UBound(Tablo2, 2)).Value2 = Tablo2

mettre
Worksheets("Transpose").[A2].Resize(UBound(Tablo2, 1), UBound(Tablo2, 2)).Value2 = Tablo2

A+

job75 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Bonjour à tous,

Une solution assez simple par formules dans le fichier joint.

Elles utilisent les noms définis Base NTime NGr NBoard.

Edit : la seule condition est qu'il y ait le même nombre de "Boards" dans tous les Groupes.

A+

ROGER2327 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Re...

richert90 à dit:
(...)
Je me suis penché sur le code de ROGER2327 pour le moment et ça marche parfaitement!
(...)

Pourvu que cela dure !

richert90 à dit:
(...)
- Si le nombre de groupe et de carte change, ce code est-il toujours bon? ou faut-il modifier des choses ?
(...)

En principe, non, à condition que la dénomination des champs à prendre en compte respecte toujours la même structure :

"Gr*B* Max"
"Gr*B*"

où * est une suite de caractères "0", "1", "2", ..., "9".

richert90 à dit:
(...)
- Comment tu arrives à sortir ce code pareil? 😱 j'aurais jamais trouvé, c'est sur..
(...)

Des rames de papier, des brassées de crayons de papier, quelques brouettées de gommes blanches, beaucoup de pratique, un peu de jus de cervelle, du rhum, de la sueur et des larmes...

Quelques commentaires sur le code :

VB:

  For i = 1 To UBound(Champs, 2)
    If Champs(1, i) Like "Gr*B* Max" Then
      ReDim Preserve m(UBound(m) + 1)
      m(UBound(m)) = Array(i, Champs(1, i))
    End If
  Next

explore la ligne d'entête de l'onglet dataBase et relève le numéro de colonne et l'intitulé lorsqu'il est de la forme "Gr*B* Max".

VB:

  For i = 0 To UBound(m)
    v = Left$(m(i)(1), Len(m(i)(1)) - 4)
    For j = 1 To UBound(Champs, 2)
      If v = Champs(1, j) Then
        ReDim Preserve b(UBound(b) + 1)
        b(UBound(b)) = Array(j, Champs(1, j))
      End If
    Next
  Next

fait la même chose, en recherchant les intitulés de la forme "Gr*B*" correspondant aux "Gr*B* Max" trouvés précédemment.

La suite du code extrait les données correspondant aux champs identifiés ci-dessus, les colle dans l'onglet Transpose, puis effectue la mise en ordre des résultats.

Bonne soirée.

ℝOGER2327
#7080

Lundi 23 Sable 141 (Sainte Viole, vierge et martyre - fête Suprême Quarte)
3 Nivôse An CCXXII, 7,2673h - bitume
2013-W52-1T17:26:29Z

richert90 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Re-bonsoir à tous 🙂

(...)
- Si le nombre de groupe et de carte change, ce code est-il toujours bon? ou faut-il modifier des choses ?
(...)
En principe, non, à condition que la dénomination des champs à prendre en compte respecte toujours la même structure :

"Gr*B* Max"
"Gr*B*"

--> Ça tombe bien, normalement la structure des champs sera toujours identique donc je pourrai utilisé le code que tu m'as fourni pour transposer le tableau 🙂.

Merci pour ces commentaires qui me font pas de mal 🙂

PS: Une dernière question, à partir de cette transposition, je vais faire un graphique en courbe avec en abscisse les dates avec les heures + les minutes, mais Excel affiche JJ/MM/AAAA 00:00 au lieu de l'heure indiqué dans les colonnes, c'est normal car c'est impossible à faire ou est-ce que ça se règle ?

Job75, je trouve aussi ta solution intéressante, suffit juste que j'applique en VBA la formule et c'est bon 🙂

paf, je vais essayer ta solution pour une autre base avec un nombre de groupe et de carte différent pour voir si j'ai bien compris

Merci à vous encore

Paf · 23 Décembre 2013

Re : Algo transposition tableau VBA

Re,

le presque même code avec quelques commentaires facilitant les modifs:

Code:

Dim TAblo, Tablo2
Dim NbElement As Integer, NbTablo2 As Integer
Dim x, NbBoard

NbElement = Worksheets("dataBase").Range("A" & Rows.Count).End(xlUp).Row - 1 'Nb ligne par colonne
NbBoard = 11 'indique le nombre de board par group

NbTablo2 = (NbElement) * NbBoard * 3 'dimensionne le nombre d'élément du tableau final . 3 étant le nb de groupe
ReDim Tablo2(NbTablo2, 6)
TAblo = Worksheets("dataBase").Range("A1:BV6")
x = 0
' de la colonne 5 à fin de tableau (dernière colonne)
For i = 5 To UBound(TAblo, 2) Step NbBoard * 2 + 2  '**2 colonnes par board +2 colonnes AVG et MAX
    For j = 0 To NbBoard * 2 - 1 Step 2
        For k = 2 To NbElement + 1
            Tablo2(x, 0) = Mid(TAblo(1, i + j), 3, 1)
            Tablo2(x, 1) = Right(TAblo(1, i + j), Len(TAblo(1, i + j)) - 4)
            Tablo2(x, 2) = TAblo(k, 1)
            Tablo2(x, 3) = TAblo(k, 2)
            Tablo2(x, 4) = TAblo(k, i + j)
            Tablo2(x, 5) = TAblo(k, i + j + 1)
            x = x + 1
        Next
    Next
Next
Worksheets("Aperçu").[A2].Resize(UBound(Tablo2, 1), UBound(Tablo2, 2)).Value = Tablo2

Bonne suite

richert90 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Merci paf!

Je récupère le nombre de groupe et le nombre de carte par groupe depuis un fichier .ini (j'ai une fonction sur VBA me permettant de récupérer ces valeurs), il me suffit de les stocker dans des variables pou ensuite les mettre dans ton code où il faut. Donc ce code marche même si par exemple on un nombre différent de groupe et un nombre différent de carte ( mais toujours le même nombre de carte dans chacun des groupes!)? La ligne ci dessous ne risque pas de modifier la donne?

Code:

For i = 5 To UBound(TAblo, 2) Step NbBoard * 2 + 2  '**2 colonnes par board +2 colonnes AVG et MAX
    For j = 0 To NbBoard * 2 - 1 Step 2
        For k = 2 To NbElement + 1
            Tablo2(x, 0) = Mid(TAblo(1, i + j), 3, 1)
            Tablo2(x, 1) = Right(TAblo(1, i + j), Len(TAblo(1, i + j)) - 4)

job75 · 23 Décembre 2013

Re : Algo transposition tableau VBA

richert90 à dit:
Job75, je trouve aussi ta solution intéressante, suffit juste que j'applique en VBA la formule et c'est bon 🙂

Oui, et ce n'est pas très difficile :

Code:

Sub Transpose()
Dim P As Range
Set P = [A2].Resize([NTime] * [NGr] * [NBoard], 6)
Application.ScreenUpdating = False
P.Columns(1).FormulaR1C1 = "=N(R[-1]C1)+NOT(MOD(ROW()-2,NTime*NBoard))"
P.Columns(2).FormulaR1C1 = "=IF(RC1<>R[-1]C1,1,R[-1]C+NOT(MOD(ROW()-2,NTime)))"
P.Columns(3).FormulaR1C1 = "=INDEX(dataBase!C1,MOD(ROW()-2,NTime)+2)"
P.Columns(4).FormulaR1C1 = "=INDEX(dataBase!C2,MOD(ROW()-2,NTime)+2)"
P.Columns(5).FormulaR1C1 = "=INDEX(OFFSET(Base,,,NTime+1),MOD(ROW()-2,NTime)+2,MATCH(""Gr""&RC1&""B""&TEXT(RC2,""00""),Base,0))"
P.Columns(6).FormulaR1C1 = "=INDEX(OFFSET(Base,,,NTime+1),MOD(ROW()-2,NTime)+2,MATCH(""Gr""&RC1&""B""&TEXT(RC2,""00"")&"" Max"",Base,0))"
P = P.Value
Range("A" & P.Rows.Count + 2 & ":F" & Rows.Count).ClearContents
End Sub

Fichiers (2).

A+

Paf · 23 Décembre 2013

Re : Algo transposition tableau VBA

Re,
Si les données nombre de groupe et de nombre de carte (board) sont déjà récupérées dans des variables, il suffit :

soit d'affecter ces valeurs aux variables du code fourni, sans toucher au reste du code:
NbBoard = LaVariable1 'indique le nombre de board par group
NbTablo2 = NbElement * NbBoard * LaVariable2

soit d'utiliser ces variables directement dans le code fourni,

NbTablo2 = NbElement * NbBoard * LaVariable2
For i = 5 To UBound(TAblo, 2) Step LaVariable1 * 2 + 2 '**2 colonnes par board +2 colonnes AVG et MAX
For j = 0 To LaVariable1 * 2 - 1 Step 2

dans tous les cas il faut adapter la définition de la plage de données:

Code:

DerCol = Worksheets("dataBase").Cells(2, Columns.Count).End(xlToLeft).Column + 1
TAblo = Range(Worksheets("dataBase").Cells(1, 1), Worksheets("dataBase").Cells(NbElement + 1, DerCol))

au lieu de

Code:

TAblo = Worksheets("dataBase").Range("A1:BV6")

A+

job75 · 23 Décembre 2013

Re : Algo transposition tableau VBA

Re,

Sur un grand tableau il est peut-être bon de passer en calcul manuel :

Code:

Sub Transpose()
Dim P As Range
Set P = [A2].Resize([NTime] * [NGr] * [NBoard], 6)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
P.Columns(1).FormulaR1C1 = "=N(R[-1]C1)+NOT(MOD(ROW()-2,NTime*NBoard))"
P.Columns(2).FormulaR1C1 = "=IF(RC1<>R[-1]C1,1,R[-1]C+NOT(MOD(ROW()-2,NTime)))"
P.Columns(3).FormulaR1C1 = "=INDEX(dataBase!C1,MOD(ROW()-2,NTime)+2)"
P.Columns(4).FormulaR1C1 = "=INDEX(dataBase!C2,MOD(ROW()-2,NTime)+2)"
P.Columns(5).FormulaR1C1 = "=INDEX(OFFSET(Base,,,NTime+1),MOD(ROW()-2,NTime)+2,MATCH(""Gr""&RC1&""B""&TEXT(RC2,""00""),Base,0))"
P.Columns(6).FormulaR1C1 = "=INDEX(OFFSET(Base,,,NTime+1),MOD(ROW()-2,NTime)+2,MATCH(""Gr""&RC1&""B""&TEXT(RC2,""00"")&"" Max"",Base,0))"
P = P.Value
Range("A" & P.Rows.Count + 2 & ":F" & Rows.Count).ClearContents
Application.Calculation = xlCalculationAutomatic
End Sub

A vérifier car je ne suis pas sûr que c'est nécessaire.

Fichiers (3).

A+

Algo transposition tableau VBA

richert90

XLDnaute Occasionnel

Pièces jointes

pierrejean

XLDnaute Barbatruc

richert90

XLDnaute Occasionnel

ROGER2327

XLDnaute Barbatruc

Pièces jointes

Paf

XLDnaute Barbatruc

richert90

XLDnaute Occasionnel

Paf

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

ROGER2327

XLDnaute Barbatruc

richert90

XLDnaute Occasionnel

Paf

XLDnaute Barbatruc

richert90

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

Paf

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Algo transposition tableau VBA

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency