1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
| Sub TEST()
Dim LastLig As Long, i As Long, j As Long
Dim Conseil As String
Dim Sh As Worksheet
Dim Tb, Res()
Application.ScreenUpdating = False
Set Sh = Worksheets("Feuil1") ' feuille de destination à adapter
Sh.UsedRange.Clear
ReDim Res(1 To 3, 1 To 1)
Res(1, 1) = "Nom conseiller": Res(2, 1) = "Nom formation": Res(3, 1) = "Score": j = 1
With Worksheets("Fichier de base")
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
Tb = .Range("A1:B" & LastLig)
For i = 1 To LastLig
If Tb(i, 2) Like "Effectuée" Then
Conseil = Tb(i - 1, 1)
ElseIf Tb(i, 2) Like "Score" Then
j = j + 1
ReDim Preserve Res(1 To 3, 1 To j)
Res(1, j) = Conseil
Res(2, j) = Tb(i - 1, 1)
Res(3, j) = Tb(i + 1, 2)
End If
Next i
End With
If j > 1 Then Sh.Range("A1").Resize(j, 3) = Application.Transpose(Res)
Set Sh = Nothing
End Sub |
Partager