XL 2021 Extraction Matricielle avec saut

legenie

XLDnaute Nouveau
Bonjour,

Je souhaiterais faire le récapitulatif des questions et réponses du quizz de tous les onglets dans l'onglet "Recap" comme illustré sur le fichier.
Je suis novice en VBA et j'ai perdu mon fichier qui avait des bouts de codes de VBA que je m'amusais souvent à combiner même si le cas-ci m'a l'air costaud 😁



Merci d'avance pour votre aide.
 

Pièces jointes

  • Quizz.xlsx
    139.4 KB · Affichages: 4

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Legenie,
Un essai en PJ avec :
VB:
Sub RecapQuestionsRéponses()
[A2:H10000].ClearContents
Application.ScreenUpdating = False
L = 1 ' Ligne de départ en écriture dans Recap
For Each F In Worksheets
    If F.Name <> "Recap" Then
        For Ligne = 4 To 24 Step 5
            L = L + 1                                   ' Ligne d'écriture
            With Sheets(F.Name)                         ' Avec la feuille lue
                Cells(L, "A") = .Cells(Ligne, "B")      ' ID
                Cells(L, "B") = Now                     ' Date
                Cells(L, "C") = .Cells(Ligne, "C")      ' Questions
                Cells(L, "D") = .Cells(Ligne + 0, "D")  ' 4 réponses
                Cells(L, "E") = .Cells(Ligne + 1, "D")
                Cells(L, "F") = .Cells(Ligne + 2, "D")
                Cells(L, "G") = .Cells(Ligne + 3, "D")
                Cells(L, "H") = Application.Max(.Range(.Cells(Ligne, "E"), .Cells(Ligne + 3, "E"))) ' N° bonne réponse
            End With
        Next Ligne
    End If
Next F
Columns.AutoFit: Rows.AutoFit ' Largeurs L et C auto
End Sub
La macro s'exécute par le bouton gris.
 

Pièces jointes

  • Quizz.xlsm
    180.3 KB · Affichages: 5

legenie

XLDnaute Nouveau
Bonsoir Legenie,
Un essai en PJ avec :
VB:
Sub RecapQuestionsRéponses()
[A2:H10000].ClearContents
Application.ScreenUpdating = False
L = 1 ' Ligne de départ en écriture dans Recap
For Each F In Worksheets
    If F.Name <> "Recap" Then
        For Ligne = 4 To 24 Step 5
            L = L + 1                                   ' Ligne d'écriture
            With Sheets(F.Name)                         ' Avec la feuille lue
                Cells(L, "A") = .Cells(Ligne, "B")      ' ID
                Cells(L, "B") = Now                     ' Date
                Cells(L, "C") = .Cells(Ligne, "C")      ' Questions
                Cells(L, "D") = .Cells(Ligne + 0, "D")  ' 4 réponses
                Cells(L, "E") = .Cells(Ligne + 1, "D")
                Cells(L, "F") = .Cells(Ligne + 2, "D")
                Cells(L, "G") = .Cells(Ligne + 3, "D")
                Cells(L, "H") = Application.Max(.Range(.Cells(Ligne, "E"), .Cells(Ligne + 3, "E"))) ' N° bonne réponse
            End With
        Next Ligne
    End If
Next F
Columns.AutoFit: Rows.AutoFit ' Largeurs L et C auto
End Sub
La macro s'exécute par le bouton gris.
Merci du fond du coeur. Ca marche !❤️❤️❤️
 

Statistiques des forums

Discussions
314 963
Messages
2 114 808
Membres
112 255
dernier inscrit
Sandrine03430