XL 2021 Extraction Matricielle avec saut

[legenie]

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.

 

[sylvanu]

Bonsoir Legenie,
Un essai en PJ avec :

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.

 

[legenie]

Bonsoir Legenie,
Un essai en PJ avec :

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 !