Public Const maxcourse = 9 'maximum de courses dans une feuille Trio, à adapter
Sub Classement(P As Range, sens) 'utilisée dans la macro RemplirTrios
Dim rang, cc%
rang = P.Columns(1).Value
cc = P.Columns.Count
P.Sort P(1, cc), sens, P(1, 3), , xlAscending, Header:=xlNo 'tri sur 2 colonnes
P.Columns(2) = rang 'la colonne B sert de colonne auxiliaire
P.Sort P(1), xlAscending, Header:=xlNo 'ordre initial
P.Columns(cc + 6) = P.Columns(2).Value 'restitution des rangs
End Sub
Sub RemplirTrios()
Dim t, F As Worksheet, nf%, n, a(), i, course$, lig, h&, r As Range
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'calcul sur ordre
For Each F In Worksheets
If F.Name Like "Trio R*" Then
nf = nf + 1
F.[C1,B3:N22,S3:X3] = "" 'RAZ
F.Rows("23:" & F.Rows.Count).Delete 'suppression des tableaux suivants
With Feuil2
'---liste des courses et adresse de la zone source---
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 2, 1 To n)
h = Application.Match("Rang*", .Cells(lig + 9, 2).Resize(20), 0)
a(1, n) = Replace(Replace(Replace(course, "Course: ", ""), "-", ""), ".", "")
a(2, n) = lig + 8 & ":" & lig + h + 7
End If
Next i
If n Then
'---création des n tableaux (vides)---
For i = 2 To n
F.Rows("1:22").Copy F.Cells(1 + 23 * (i - 1), 1) '1 ligne de séparation
Next i
'---remplissage des n tableaux
For i = 1 To n
lig = 1 + 23 * (i - 1)
Set r = .Range(a(2, i)): h = r.Rows.Count
'---Course---
F.Cells(lig, 3) = a(1, i)
lig = lig + 2
'---Ml3---
F.Cells(lig, 3).Resize(h) = r.Columns(5).Value
'---Tot2---
F.Cells(lig, 4).Resize(h) = r.Columns(17).Value
Classement F.Cells(lig, 1).Resize(h, 4), xlDescending
'---A3P---
F.Cells(lig, 5).Resize(h) = r.Columns(18).Value
Classement F.Cells(lig, 1).Resize(h, 5), xlAscending
'---Fit1---
F.Cells(lig, 6).Resize(h) = r.Columns(20).Value
Classement F.Cells(lig, 1).Resize(h, 6), xlDescending
'---Fit2---
F.Cells(lig, 7).Resize(h) = r.Columns(25).Value
F.Cells(lig, 2).Resize(h) = "=IF((RC[5]=""A"")+(RC[5]=""B""),RC[5],"""")"
F.Cells(lig, 7).Resize(h) = F.Cells(lig, 2).Resize(h).Value
Classement F.Cells(lig, 1).Resize(h, 7), xlAscending
'---V"L---
F.Cells(lig, 8).Resize(h) = r.Columns(29).Value
Classement F.Cells(lig, 1).Resize(h, 8), xlAscending
'---N°---
F.Cells(lig, 2).Resize(h) = r.Columns(2).Value
'---remplissage PRN---
F.Cells(lig, 16).Resize(h).Calculate 'recalcul des formules en colonne P
F.Cells(lig, 1).Resize(h, 16).Sort F.Columns(16), xlDescending, Header:=xlNo 'tri sur colonne P
F.Cells(lig, 19).Resize(, 6) = Application.Transpose(F.Cells(lig, 2).Resize(6))
F.Cells(lig, 1).Resize(h, 16).Sort F.Cells(lig, 1), xlAscending, Header:=xlNo 'ordre initial
Next i
End If
End With
'F.Columns.AutoFit 'facultatif, ajustement largeur
End If
Next F
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Remplissage des " & nf & " feuilles Trios en " & Format(Timer - t, "0.00 \s")
End Sub
