Sub Regroupement_pmo()
Dim S As Worksheet
Dim R As Range
Dim var
Dim h&
Dim i&
Dim cpt&
Dim T()
Dim A$
On Error GoTo Erreur
Application.ScreenUpdating = False
For h& = 1 To 10
A$ = "Quiz " & h&
Set S = Sheets(A$)
Set R = S.[w1].CurrentRegion
var = R
For i& = 2 To UBound(var, 1)
If LCase(var(i&, 23)) = "yes" Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 11, 1 To cpt&)
T(1, cpt&) = A$
T(2, cpt&) = i&
T(3, cpt&) = var(i&, 11)
T(4, cpt&) = var(i&, 10)
T(5, cpt&) = var(i&, 12)
T(6, cpt&) = var(i&, 13)
T(7, cpt&) = var(i&, 17)
T(8, cpt&) = var(i&, 19)
T(9, cpt&) = var(i&, 20)
T(10, cpt&) = var(i&, 21)
T(11, cpt&) = CLng(CDate(var(i&, 22)))
End If
Next i&
Next h&
A$ = "Base"
Set S = Sheets(A$)
S.Activate
S.Cells.Delete
Set R = S.Range(S.Cells(2, 1), Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
var = Array("Quiz", "Row", "Last Name", "First Name", "Birthday", "Email", "City", "Q1", "Q2", "Q3", "Assign a date")
Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(var) + 1))
R = var
R.Interior.ColorIndex = 37
R.HorizontalAlignment = xlCenter
R.Font.Bold = True
With ActiveWindow
.SplitRow = 1
.FreezePanes = True
End With
S.Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Exit Sub
Erreur:
If Err = 9 Then
MsgBox "The WorkSheet ''" & A$ & "'' cannot be found"
Else
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
End If
Application.ScreenUpdating = True
End Sub