[ RESOLU ] Modifier une macro,qui suppriment des plage...

Bonjour Le Forum

J'ai anouveau besoin de Vous

Dans mon fichier pour les courses de chx,une macro suppriment des plages et efface les données

de la veille,pour mettre en place les nouvelles

Voici le VBA

Sub RemplirTrios()
Dim t$, f As Worksheet, nf%, n, a(), i, course$, lig, h&, R As Range, j%, li&
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each f In Worksheets
If f.Name Like "Trio R*" Then
nf = nf + 1
f.[C1,B3:N22,S3:X3,AB3:AC22,S18:T18,S11:U11,AG3:AH22,AL3:AQ3,AL19:AN20] = "" 'RAZ
f.[S3:X3,AB3:AC22,AK12,AN12,AK16,AN16,S11:U11,AL3:AQ3,AL20:AN20,AK12,AK16,AN12,AN16] = 0
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 + 5 & ":" & 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 'a(1,i)= course a(2,i) ligne de 20:28
'---Course---
f.Cells(lig, 3) = a(1, i)
lig = lig + 2
'---Matin---
f.Cells(lig, 3).Resize(h) = R.Columns(5).Value
'---Tot2---
f.Cells(lig, 4).Resize(h) = R.Columns(16).Value
'---A3P---
f.Cells(lig, 5).Resize(h) = R.Columns(17).Value
'---Fit1---
f.Cells(lig, 6).Resize(h) = R.Columns(9).Value
'---Fit2---
f.Cells(lig, 7).Resize(h) = R.Columns(10).Value
'---V"L---
f.Cells(lig, 8).Resize(h) = R.Columns(29).Value
'---N°---
f.Cells(lig, 2).Resize(h) = R.Columns(2).Value
aa = f.Cells(lig, 1).Resize(h, 5)
Call ClasserA3P
f.Cells(lig, 11).Resize(UBound(bb), 1) = bb
f.Cells(lig, 1).Resize(h, 14).Sort f.Columns(6), xlDescending, Header:=xlNo
aa = f.Cells(lig, 1).Resize(h, 14)
Call ClasserFit1
f.Cells(lig, 12).Resize(UBound(bb), 1) = bb
f.Cells(lig, 1).Resize(h, 14).Sort f.Columns(7), xlDescending, Header:=xlNo
aa = f.Cells(lig, 1).Resize(h, 7)
Call ClasserFit2
f.Cells(lig, 13).Resize(UBound(bb), 1) = bb
f.Cells(lig, 1).Resize(h, 14).Sort f.Columns(8), xlAscending, Header:=xlNo
aa = f.Cells(lig, 1).Resize(h, 8)
Call ClasserVL
f.Cells(lig, 14).Resize(UBound(bb), 1) = bb
f.Cells(lig, 1).Resize(h, 14).Sort f.Columns(4), xlDescending, Header:=xlNo
aa = f.Cells(lig, 1).Resize(h, 10)
Call ClasserTot2
f.Cells(lig, 10).Resize(UBound(bb), 1) = bb
li = Split(a(2, i), ":")(1)
aa = .Range(.Cells(li + 8, 19), .Cells(li + 10, 23))
Call Extraire
f.Cells(lig, 38).Resize(1, UBound(bb, 2)) = bb
f.Cells(lig, 1).Resize(h, 14).Sort f.Columns(1), xlAscending, Header:=xlNo
f.Cells(lig, 16).Resize(h).Calculate 'recalcul des formules en colonne P
f.Cells(lig, 15).Resize(h).Calculate 'recalcul des formules en colonne O
f.Cells(lig, 1).Resize(h, 16).Sort f.Columns(16), xlDescending, Header:=xlNo
'---remplissage PRN---
j = Application.CountIf(f.Cells(lig, 16).Resize(h), ">0")
If j > 6 Then j = 6
If j Then f.Cells(lig, 19).Resize(, j) = Application.Transpose(f.Cells(lig, 2).Resize(j))
aa = f.Cells(lig, 15).Resize(h, 2)
f.Cells(lig, 28).Resize(UBound(aa), 2) = aa
f.Cells(lig, 1).Resize(h, 16).Sort f.Columns(1), xlAscending, Header:=xlNo
Next i
End If
End With
End If
Next f
Application.Calculation = xlCalculationAutomatic
Call ClasserPoint
Application.ScreenUpdating = True
MsgBox "Remplissage des " & nf & " feuilles Trios en " & Format(Timer - t, "0.00s")
End Sub


Merci pour votre aide

Guido