[résolu] Mini casse-tête ;-) Transposer des mini tableaux empilés de diverses tailles

[peper_eliot]

Au cas ou vous auriez déjà traité un casse-tête de ce type...
... tellement casse-tête que je ne sais pas quel titre lui donner

Bonjour à tous, ou plutôt bonsoir

Je suis confronté chaque année au même souci d'extraction et je suis obligé de me farcir une mise en forme pas possible pour que le tableau puisse être lisible... en colonne!

Alors, comme une image vaut 1000 mots, je vous colle un "résumé" de la situation qui j'espère sera parlant


Et oui, les données ne sont pas toutes organisées en colonne... par contre, j'ai des points de repère fixe... la dernière colonne, c'est le "Total", l'ordre d'extraction des colonnes (CC-MC-TP-MO) est toujours le même... sauf que s'il n'y a pas de données dans l'un ou l'autre des semestres, la colonne correspondante n'est pas affichée... d'ou cette extraction en barre... escalier... je ne sais même pas comment la décrire

Au départ, je me suis penché sur le problème en pensant pouvoir insérer les colonnes manquantes dans l'extraction elle même, mais je n'y suis point arrivé...
Ensuite, je me suis dit qu'il serait plus sage de passer par une recopie des valeurs dans un autre tableau... mais maintenant je tourne en boucle pour savoir pas quel bout commencer...

Alors, si vous avez déjà été confronté à un problème similaire... et que vous avez toujours votre "classeur à macro souvenir" sous le coude, je suis preneur

 

[Victor21]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

Bonsoir, peper_eliot.

Il n'est pas sûr que je puisse vous aider à résoudre ce cas.

Ce qui est sûr, par contre, en ne joigant qu'une copie écran, au lieu d'un extrait de votre fichier, c'est que vous faites tout pour minimiser les chances de propositions...

Un fichier joint en exemple (allez en mode avancé, cliquez sur le trombone, et laissez-vous guider : c'est sans douleur )vaut bien, amha, 1000 images, aussi belles soient-elles...

 

[peper_eliot]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

Oh, je veux bien te mettre le fichier, mais ça ne changera pas grand chose...
la question est plutôt "par quel bout prendre ce problème..."

 

[phlaurent55]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

Bonjour à tous,

Oh, je veux bien te mettre le fichier, mais ça ne changera pas grand chose...

ça change tout, cela fait plus d'une demi-heure que j'ai débuté la construction du fichier au départ de cette photo et je découvre le fichier juste avant d'envoyer ma réponse

voici le résultat en pièce jointe
........ j'ai laissé un peu de travail pour la dernière partie du tableau

à+
Philippe

 

[peper_eliot]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

Oups.. désolé... je te dois une geuze alors

J'avais également pensé passer par des formules matricielles, mais il y a deux bémols
1) L'extraction est une succession de tableaux supperposés (environs 30 sur 800 lignes)
2) les entêtes de l'extraction ne permettent pas de différencier les semestres

Perso, je pense qu'il faut, sur la zone totale de l'extraction, partir de la dernière cellule à droite, celle du total.
à partir de là, je peux connaitre le N° de ligne d'en-tête de chaque tableau et le nombre de colonnes Sem1-Sem2-Total puisque ça me fait par exemple :
MM-TP-MC-TP-MC-TP-Σ soit 7 colonnes
7 colonnes - 1(Σ) = 6 colonnes
6 colonnes / 3 = 2 colonnes pour chaque semestre et le cumul

 

[hoerwind]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

Bonjour, salut Victor et Philippe,

Une autre formule sous la pièce jointe.
Seules les lignes 4 à 9 ont été traitées, je te laisse faire la suite.

 

[peper_eliot]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

Merci à tous pour vos suggestions.

De mon côté, je me le tente par VBA car, dans tous les cas, les formules matricielles sont limitées a chaque "mini" tableau de l'extraction et necessite la recopie manuelle des en-têtes

Je n'ai pas bien avancé, mais...

Sub test2()
Dim c, c1
Dim i, t, l
Dim genre
Dim nb_val
i = 0
t = 0
'Je balaye la colonne N
For Each c In Worksheets("Feuil1").Range("N3:N23")
    t = t + 1
    If c.Value = ChrW(931) Then
        Range(c.Address).Select
        MsgBox "le tableau " & i & " a " & l & " lignes et " & nb_val & " valeurs/trim"
        l = 0
        i = i + 1
        nb_val = (c.Column - 2) / 3
            l = 0
        MsgBox "tableau " & i & vbCr & "nb val/trim : " & nb_val ' & vbCr & "nb lignes " & l
    Else: Range(c.Address).Select
       If ActiveCell = "" Then
       Selection.End(xlToLeft).Activate
       End If
    If ActiveCell = ChrW(931) Then
    MsgBox "le tableau " & i & " a " & l & " lignes et " & nb_val & " valeurs/trim"
    l = 0
    i = i + 1
    nb_val = (ActiveCell.Column - 2) / 3
    MsgBox "tableau " & i & vbCr & "nb val/trim : " & nb_val
    End If
    End If
    l = l + 1
Next c
MsgBox "le tableau " & i & " a " & l & " lignes et " & nb_val & " valeurs/trim"

End Sub

Maintenant, je vais chercher le moyen de copier les en-têtes et leur valeurs dans le bon ordre sur le tableau de droite
Je pensais passer par un Select Case genre = CC ... genre = MC ...

Mais bon, ce sera pour demain

 

[peper_eliot]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

"Demain" étant encore en cours, voici un petit point d'étape

Option Explicit
Dim c, c1
Dim i, t, l, i2
Dim genre
Dim nb_val
Sub Balayage()
i = 0
t = 0 'numéro de ligne de la zone d'extraction traitée

'Je balaye la colonne N
For Each c In Worksheets("Feuil1").Range("N3:N23")
    t = t + 1
    If c.Value = ChrW(931) Then
        Range(c.Address).Select
        l = 0
        i = i + 1
        nb_val = (c.Column - 2) / 3
            l = 0
        MsgBox "tableau " & i & vbCr & "nb val/trim : " & nb_val ' & vbCr & "nb lignes " & l
'==>>__APPEL : boucle de recopie des EN-TETES__<<==
Application.Run ("ReportEnTete")

    Else: Range(c.Address).Select
        If ActiveCell = "" Then
        Selection.End(xlToLeft).Activate
        End If
    If ActiveCell = ChrW(931) Then
    l = 0
    i = i + 1
    nb_val = (ActiveCell.Column - 2) / 3
'==>>__APPEL : boucle de recopie des EN-TETES__<<==
Application.Run ("ReportEnTete")
''    Else
'''==>>__APPEL : boucle de recopie des VALEURS__<<==
''Application.Run ("ReportValeurs")

    End If
    End If
    l = l + 1
Next c
End Sub

'__________________________________________________________________
Sub ReportEnTete()
'Application.Run ("ReportEnTete")
For i2 = 1 To nb_val
    genre = ActiveCell.Offset(0, -i2).Value
    Select Case genre
        Case "CC"
            Range("P" & ActiveCell.Row).FormulaR1C1 = "CC"
            Range("T" & ActiveCell.Row).FormulaR1C1 = "CC"
        Case "MC"
            Range("Q" & ActiveCell.Row).FormulaR1C1 = "MC"
            Range("U" & ActiveCell.Row).FormulaR1C1 = "MC"
        Case "TP"
            Range("R" & ActiveCell.Row).FormulaR1C1 = "TP"
            Range("V" & ActiveCell.Row).FormulaR1C1 = "TP"
        Case "MO"
            Range("S" & ActiveCell.Row).FormulaR1C1 = "MO"
            Range("W" & ActiveCell.Row).FormulaR1C1 = "MO"
    End Select
Next
End Sub

J'arrive donc a passer les en-têtes dans le tableau... maintenant, faut que je travaille sur le passage des valeurs

 

[peper_eliot]

Re : Au cas ou vous auriez déjà traité un casse-tête de ce type...

Bon, ben pour éviter de faire de ce problème un plat indigeste, J'ai tout remis à plat...
J'en ai même profité pour me prendre un peu le choux avec les ARRAY... Et ben, pas besoin de faire un ARRAY sur image... y a pas photo, c'est hyper rapide

Alors voilà, je passe le post en résolu et je vous remercie tous les trois, victor21, phlaurent55, hoerwind pour m'avoir initié aux formules matricielles

Et une spéciale dédicace à Misange pour sa page sur les Array Ce lien n'existe plus

Voici donc la solution que je vous propose :

Option Explicit
Option Base 1
'====================================
Sub Balayage2()
 Dim cl
 Dim mtR1, mtR2, mtC1, mtC2, mtNbR, mtNbC, valTrim As Integer
 Dim inc, inc2, x As Integer
 Dim code As String
 Dim mtCopie As Range
 Dim array_copy()
 '===================================
 'Un petit chrono ?
 Dim StartTime1, StartTime2 As Double
 Application.ScreenUpdating = False
 StartTime1 = Timer
 '===================================
 'Boucle sur première colonne zone extract
 For Each cl In Range("B3:B23")
    If Not IsNumeric(cl) Then 'Début d'un mini tableau
    cl.Activate
    'validation des variables de dimension du mini tableau
    mtR1 = cl.Row
    mtC1 = cl.Column
       Selection.End(xlToRight).Activate
    mtC2 = ActiveCell.Column
    mtNbC = mtC2 - mtC1 + 1
       'boucle de comptage des lignes
       Do
       inc = inc + 1
       Loop While IsNumeric(Cells(mtR1 + 1 + inc, mtC2)) And (Cells(mtR1 + 1 + inc, mtC2)) <> ""
    mtNbR = inc + 1
    mtR2 = mtR1 + mtNbR - 1
    valTrim = (mtC2 - mtC1) / 3
       inc = 0 'RAZ compteur
''+++++MSGBOX DE VERIFICATION DES DIMENSIONS DU MINI TABLEAU
''===========a décommenter si besoin============
'    MsgBox "mtR1: N°ligne départ" & vbTab & mtR1 & vbCr & _
            "mtR2: N°ligne fin" & vbTab & mtR2 & vbCr & _
            "mtNbR: Total lignes" & vbTab & mtNbR & vbCr & _
            "mtC1: N°col départ" & vbTab & mtC1 & vbCr & _
            "mtC2: N°col fin" & vbTab & mtC2 & vbCr & _
            "mtNbC: Total col" & vbTab & mtNbC & vbCr & _
            "valTrim: Val/trim" & vbTab & valTrim
'===================================
'Boucle de sélection des données en colonnes de chaque mini tableau
    x = 0
    For inc2 = mtC1 To mtC1 + (valTrim * 2) - 1
    x = x + 1
    code = Cells(mtR1, inc2) 'Recherche du code pour la boucle SELECT CASE
    'Déclaration de la zone à transférer en range
    Set mtCopie = Range(Cells(mtR1, inc2), Cells(mtR2, inc2))
'Passage des valeurs en Copy
'Tout le code de la procédure relatif à la copie est commenté
    'mtCopie.Copy
'Passage des valeurs dans un Array
    ReDim array_copy(1 To mtNbR, 1 To 1)
    array_copy() = mtCopie.Value
'+++TRANSFERT++++++++++++++
    If x <= valTrim Then
        Select Case code
        Case "CC"
        'Cells(mtR1, 16).Activate
Range(Cells(mtR1, 16), Cells(mtR1 + UBound(array_copy) - 1, 16)).Value = array_copy
        Case "MC"
        'Cells(mtR1, 17).Activate
Range(Cells(mtR1, 17), Cells(mtR1 + UBound(array_copy) - 1, 17)).Value = array_copy
        Case "TP"
        'Cells(mtR1, 18).Activate
Range(Cells(mtR1, 18), Cells(mtR1 + UBound(array_copy) - 1, 18)).Value = array_copy
        Case "MO"
        'Cells(mtR1, 19).Activate
Range(Cells(mtR1, 19), Cells(mtR1 + UBound(array_copy) - 1, 19)).Value = array_copy
        End Select
        'ActiveSheet.Paste
    End If
'+++TRANSFERT++++++++++++++
    If x > valTrim Then
        Select Case code
        Case "CC"
Range(Cells(mtR1, 20), Cells(mtR1 + UBound(array_copy) - 1, 20)).Value = array_copy
        'Cells(mtR1, 20).Activate
        Case "MC"
Range(Cells(mtR1, 21), Cells(mtR1 + UBound(array_copy) - 1, 21)).Value = array_copy
        'Cells(mtR1, 21).Activate
        Case "TP"
Range(Cells(mtR1, 22), Cells(mtR1 + UBound(array_copy) - 1, 22)).Value = array_copy
        'Cells(mtR1, 22).Activate
        Case "MO"
Range(Cells(mtR1, 23), Cells(mtR1 + UBound(array_copy) - 1, 23)).Value = array_copy
        'Cells(mtR1, 23).Activate
        End Select
    'ActiveSheet.Paste
    End If
    Next
    End If
 Next
 
Application.ScreenUpdating = True
Range("C30").Value = Format(Timer - StartTime1, "00.00") & " secondes"
'Le résultat :
'==> 15,50 SECONDES EN MODE COPIE
'==> 00,16 CENTIEMES AVEC LES ARRAY!!!
'Comme quoi, ça vaut le coup de s'y pencher un peu ;-)
 End Sub