Guido
XLDnaute Accro
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
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