Const maxcourse = 9 'maximum de courses dans une feuille Trio, à adapter
Sub RemplirTrios()
Dim t, F As Worksheet, nf%, n, a(), i, course$, lig, h&, r As Range
t = Timer
Application.ScreenUpdating = False
For Each F In Worksheets
If F.Name Like "Trio R*" Then
nf = nf + 1
F.[C1,B3:AE22,Q25:AE25,Q29:AE29,Z30:AE30,R31:W32] = "" 'RAZ dont 1ère zone
F.[B23:P32].Clear 'RAZ 2ème et 3ème zones
F.Rows("33:" & F.Rows.Count).Delete 'suppression des tableaux suivants
With Feuil2
'---liste des courses et adresses des 3 zones sources---
n = 0: Erase a
For i = 1 To maxcourse
course = "Course: R." & Mid(F.Name, 7) & "-C." & i
lig = Application.Match(course & "*", .[B:B], 0)
If IsNumeric(lig) Then
n = n + 1
ReDim Preserve a(1 To 4, 1 To n)
h = Application.Match("Rang*", .Cells(lig + 9, 2).Resize(20), 0)
a(1, n) = course
a(2, n) = lig + 8 & ":" & lig + h + 7 '1ère zone
a(3, n) = "B" & lig + h + 8 & ":I" & lig + h + 17 '2ème zone
a(4, n) = "S" & lig + h + 8 & ":W" & lig + h + 14 '3ème zone
End If
Next i
If n Then
'---création des n tableaux (vides)---
For i = 2 To n
F.Rows("1:32").Copy F.Cells(1 + 33 * (i - 1), 1) '1 ligne de séparation
Next i
'---remplissage des n tableaux
For i = 1 To n
lig = 1 + 33 * (i - 1)
Set r = .Range(a(2, i)): h = r.Rows.Count
'---Course---
F.Cells(lig, 3) = a(1, i)
lig = lig + 2
'---1ère zone N°---
F.Cells(lig, 2).Resize(h) = r.Columns(2).Value
F.Cells(lig, 2).Resize(h).Copy Intersect(F.Rows(lig).Resize(h), _
F.[F:F,I:I,K:K,N:N,Q:Q,T:T,W:W,Z:Z,AC:AC])
'---1ère zone Mio---
F.Cells(lig, 4).Resize(h) = r.Columns(4).Value
F.Cells(lig, 4).Resize(h).Copy Intersect(F.Rows(lig).Resize(h), _
F.[H:H,L:L,O:O,R:R,U:U,X:X,AA:AA,AD:AD])
'---1ère zone Ml3---
F.Cells(lig, 5).Resize(h) = r.Columns(5).Value
'---1ère zone OVER---
F.Cells(lig, 3).Resize(h) = "=RC[1]-RC[2]" 'formule
F.Cells(lig, 3).Resize(h) = F.Cells(lig, 3).Resize(h).Value 'valeurs
F.Cells(lig, 3).Resize(h).Copy Intersect(F.Rows(lig).Resize(h), F.[G:G,J:J])
'---1ère zone APIC---
F.Cells(lig, 13).Resize(h) = r.Columns(11).Value
'---1ère zone Ar---
F.Cells(lig, 16).Resize(h) = r.Columns(15).Value
'---1ère zone Tot---
F.Cells(lig, 19).Resize(h) = r.Columns(16).Value
'---1ère zone Tot2---
F.Cells(lig, 22).Resize(h) = r.Columns(17).Value
'---1ère zone A3P---
F.Cells(lig, 25).Resize(h) = r.Columns(18).Value
'---1ère zone Fit2---
F.Cells(lig, 28).Resize(h) = r.Columns(25).Value
'---1ère zone Dern---
F.Cells(lig, 31).Resize(h) = r.Columns(35).Value
'---2ème zone---
.Range(a(3, i)).Copy F.Cells(lig + 20, 2)
'---3ème zone---
.Range(a(4, i)).Copy F.Cells(lig + 20, 11)
Next i
End If
End With
F.Columns.AutoFit 'facultatif, ajustement largeur
End If
Next F
Application.ScreenUpdating = True
MsgBox "Remplissage des " & nf & " feuilles Trios en " & Format(Timer - t, "0.00 \s")
End Sub
27 "..E...F..G..H...I.) dont le résultats 
