(...) Seul hic,la macros efface le contenu qui se trouve de la ligne 15 a 27 voir bien plus (...)
Re,
Dans la foulée j'ai complété dans ce fichier (9) les tableaux ARRIVEE OFFICIELLE.
Voyez les 4 formules en A17 B17 C17 D17 à tirer vers le bas puis à recopier sur les autres tableaux.
Je ne sais pas ce qu'il faut mettre dans les colonnes ZC.
A+
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim Frecap As Worksheet, F As Worksheet, i&, lig&, x$, P As Range, rc As Byte
Dim colrecap%, ligrecap&, j As Byte, k As Byte
Static recap As Boolean 'mémorise la variable
Set Frecap = Feuil1 'CodeName de la feuille Récap
Set F = Feuil2 'CodeName de la feuille Prono
With Sh
If .Name Like "TAB R#*" Then
Application.ScreenUpdating = False
.Cells.Clear 'RAZ
lig = 1
x = "Course: R." & Val(Mid(.Name, 6)) & "-*"
For i = 1 To F.Cells(.Rows.Count, 2).End(xlUp).Row
If F.Cells(i, 2) Like x Then
'---copie du tableau source---
Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
rc = P.Rows.Count
P.Rows("1:8").Copy .Cells(lig, 1) 'début
P.Rows(9).Resize(rc - 18, 6).Copy .Cells(lig + 8, 1) 'milieu, colonnes A à F
P(rc - 9, 2).Resize(, 3).Copy .Cells(lig + 28, 2) 'pour les formats
.Cells(lig + 28, 2) = "Chevaux"
P.Rows(rc - 8).Resize(9).Copy .Cells(lig + 29, 1) 'fin
'---initialisation et 1ère colonne du tableau dans Récap---
If recap Then
colrecap = 6 * Val(Mid(.Name, 6)) - 5
ligrecap = Frecap.Columns(colrecap) _
.Find("", Frecap.Cells(2, colrecap), xlValues, , xlByColumns).Row
Frecap.Cells(ligrecap, colrecap) = Trim(Mid(.Cells(lig, 2), 9, 8))
End If
'---traitement du milieu du tableau---
With .Cells(lig + 8, 1).Resize(20, 8) '2 colonnes auxiliaires G et H
.Columns(3).Interior.ColorIndex = xlNone 'RAZ des couleurs
For j = 1 To 20
If .Cells(j, 2) <> "" Then
.Cells(j, 1) = .Cells(j, 2)
.Cells(j, 4) = Val(Replace(.Cells(j, 4), ",", "."))
.Cells(j, 5) = Val(Replace(.Cells(j, 5), ",", "."))
.Cells(j, 3) = .Cells(j, 4) - .Cells(j, 5)
If .Cells(j, 3) < 0 Then .Cells(j, 7) = -.Cells(j, 3) _
Else .Cells(j, 8) = .Cells(j, 3) 'séparation des valeurs
Else
For k = 1 To 20
If Application.CountIf(.Columns(1), k) = 0 Then .Cells(j, 1) = k: Exit For
Next k
End If
Next j
.Sort .Columns(7), xlAscending, Header:=xlNo 'tri des valeurs < 0
If .Cells(1, 7) <> "" Then
.Cells(1, 3).Interior.ColorIndex = 3: .Cells(1, 3).Font.ColorIndex = 6
.Cells(1, 3).Copy .Cells(22, 5)
.Cells(1, 2).Copy .Cells(21, 5)
If recap Then Frecap.Cells(ligrecap, colrecap + 1) = .Cells(1, 3): _
Frecap.Cells(ligrecap, colrecap + 2) = .Cells(1, 2)
End If
.Sort .Columns(8), xlAscending, Header:=xlNo 'tri des valeurs >= 0
If .Cells(1, 8) <> "" Then
.Cells(1, 3).Interior.ColorIndex = 49: .Cells(1, 3).Font.ColorIndex = 6
.Cells(1, 3).Copy .Cells(22, 6)
.Cells(1, 2).Copy .Cells(21, 6)
If recap Then Frecap.Cells(ligrecap, colrecap + 3) = .Cells(1, 3): _
Frecap.Cells(ligrecap, colrecap + 4) = .Cells(1, 2)
End If
.Columns(7).Resize(, 2) = "" 'RAZ des colonnes auxiliaires
.Sort .Columns(1), xlAscending, Header:=xlNo 'tri dans l'ordre normal
'---mises en forme de la 1ère colonne---
With .Columns(1)
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
End With
'---bordures---
.Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlThin
lig = lig + 38
End If
Next i
ElseIf .Name = Frecap.Name Then
Application.ScreenUpdating = False
.Rows("3:12").ClearContents 'RAZ
recap = True
For Each Sh In Worksheets
If Sh.Name Like "TAB R#*" Then Workbook_SheetActivate Sh
Next Sh
recap = False
End If
ActiveCell.Select
With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub
Dans la journée ,je vais ajouté une MFC afin de visualiser la reussite de chaque pronos selon l'arrivee.
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim Frecap As Worksheet, F As Worksheet, i&, lig&, x$, P As Range, rc As Byte
Dim colrecap%, ligrecap&, j As Byte
Static recap As Boolean 'mémorise la variable
Set Frecap = Feuil1 'CodeName de la feuille Récap
Set F = Feuil2 'CodeName de la feuille Prono
With Sh
If .Name Like "TAB R#*" Then
Application.ScreenUpdating = False
.Cells.Clear 'RAZ
lig = 1
x = "Course: R." & Val(Mid(.Name, 6)) & "-*"
For i = 1 To F.Cells(.Rows.Count, 2).End(xlUp).Row
If F.Cells(i, 2) Like x Then
'---copie du tableau source---
Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
rc = P.Rows.Count
P.Copy .Cells(lig, 1)
.Rows(lig + rc - 10) = "": .Cells(lig + rc - 10, 2) = "Chevaux"
'---initialisation et 1ère colonne du tableau dans Récap---
If recap Then
colrecap = 6 * Val(Mid(.Name, 6)) - 5
ligrecap = Frecap.Columns(colrecap) _
.Find("", Frecap.Cells(2, colrecap), xlValues, , xlByColumns).Row
Frecap.Cells(ligrecap, colrecap) = Trim(Mid(.Cells(lig, 2), 9, 8))
End If
'---traitement du milieu du tableau---
With .Cells(lig + 8, 1).Resize(rc - 18, 8) '2 colonnes auxiliaires G et H
.Columns(7).Resize(, P.Columns.Count - 6).Clear 'RAZ à partir de la colonne G
.Columns(3).Interior.ColorIndex = xlNone 'RAZ des couleurs en colonne C
For j = 1 To rc - 18
.Cells(j, 1) = j
.Cells(j, 4) = Val(Replace(.Cells(j, 4), ",", "."))
.Cells(j, 5) = Val(Replace(.Cells(j, 5), ",", "."))
.Cells(j, 3) = .Cells(j, 4) - .Cells(j, 5)
If .Cells(j, 3) < 0 Then .Cells(j, 7) = -.Cells(j, 3) _
Else .Cells(j, 8) = .Cells(j, 3) 'séparation des valeurs
Next j
.Sort .Columns(7), xlAscending, Header:=xlNo 'tri des valeurs < 0
If .Cells(1, 7) <> "" Then
.Cells(1, 3).Interior.ColorIndex = 3: .Cells(1, 3).Font.ColorIndex = 6
.Cells(1, 3).Copy .Cells(rc - 16, 5)
.Cells(1, 2).Copy .Cells(rc - 17, 5)
If recap Then Frecap.Cells(ligrecap, colrecap + 1) = .Cells(1, 3): _
Frecap.Cells(ligrecap, colrecap + 2) = .Cells(1, 2)
End If
.Sort .Columns(8), xlAscending, Header:=xlNo 'tri des valeurs >= 0
If .Cells(1, 8) <> "" Then
.Cells(1, 3).Interior.ColorIndex = 49: .Cells(1, 3).Font.ColorIndex = 6
.Cells(1, 3).Copy .Cells(rc - 16, 6)
.Cells(1, 2).Copy .Cells(rc - 17, 6)
If recap Then Frecap.Cells(ligrecap, colrecap + 3) = .Cells(1, 3): _
Frecap.Cells(ligrecap, colrecap + 4) = .Cells(1, 2)
End If
.Columns(7).Resize(, 2) = "" 'RAZ des colonnes auxiliaires
.Sort .Columns(1), xlAscending, Header:=xlNo 'tri dans l'ordre normal
'---mises en forme de la 1ère colonne---
With .Columns(1)
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
End With
'---bordures---
.Cells(lig, 2).Resize(rc, P.Columns.Count - 1).Borders.Weight = xlThin
lig = lig + rc
End If
Next i
ElseIf .Name = Frecap.Name Then
Application.ScreenUpdating = False
.Rows("3:12").ClearContents 'RAZ
recap = True
For Each Sh In Worksheets
If Sh.Name Like "TAB R#*" Then Workbook_SheetActivate Sh
Next Sh
recap = False
End If
ActiveCell.Select
With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim Frecap As Worksheet, F As Worksheet, i&, lig&, x$, P As Range, rc As Byte
Dim colrecap%, ligrecap&, y$, t, j As Byte
Static recap As Boolean 'mémorise la variable
Set Frecap = Feuil1 'CodeName de la feuille Récap
Set F = Feuil2 'CodeName de la feuille Prono
With Sh
If .Name Like "TAB R#*" Then
Application.ScreenUpdating = False
.Cells.Clear 'RAZ
lig = 1
x = "Course: R." & Val(Mid(.Name, 6)) & "-*"
For i = 1 To F.Cells(.Rows.Count, 2).End(xlUp).Row
If F.Cells(i, 2) Like x Then
'---copie du tableau source---
Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
rc = P.Rows.Count
P.Copy .Cells(lig, 1)
.Rows(lig + rc - 10) = "": .Cells(lig + rc - 10, 2) = "Chevaux"
'---initialisation et en-têtes des tableaux dans Récap---
If recap Then
colrecap = 6 * Val(Mid(.Name, 6)) - 5
ligrecap = Frecap.Columns(colrecap) _
.Find("", Frecap.Cells(2, colrecap), xlValues, , xlByColumns).Row
y = Trim(Mid(P(1, 2), 9, 8))
y = Replace(Replace(y, ".", ""), "-", "")
If ligrecap = 3 Then Frecap.Cells(2, colrecap) = Split(y, "C")(0)
Frecap.Cells(ligrecap, colrecap) = y
Frecap.Cells(ligrecap + 14, colrecap) = y 'tableau des arrivées
End If
'---traitement du milieu du tableau---
With .Cells(lig + 8, 1).Resize(rc - 18, 8) '2 colonnes auxiliaires G et H
.Columns(7).Resize(, P.Columns.Count - 6).Clear 'RAZ à partir de la colonne G
.Columns(3).Clear 'RAZ colonne C
.Columns(3).HorizontalAlignment = xlCenter 'centrage
t = .Value 'matrice, plus rapide
For j = 1 To rc - 18
t(j, 1) = j
t(j, 4) = Val(Replace(t(j, 4), ",", "."))
t(j, 5) = Val(Replace(t(j, 5), ",", "."))
t(j, 3) = t(j, 4) - t(j, 5)
If t(j, 3) < 0 Then
t(j, 7) = -t(j, 3)
ElseIf t(j, 3) > 0 Then 'valeurs zéro non traitées
t(j, 8) = t(j, 3)
End If
Next j
.Value = t
.Sort .Columns(7), xlAscending, Header:=xlNo 'tri des valeurs < 0
If .Cells(1, 7) <> "" Then
.Cells(1, 3).Interior.ColorIndex = 3: .Cells(1, 3).Font.ColorIndex = 6
.Cells(1, 3).Copy .Cells(rc - 16, 5)
.Cells(1, 2).Copy .Cells(rc - 17, 5)
If recap Then Frecap.Cells(ligrecap, colrecap + 1) = .Cells(1, 3): _
Frecap.Cells(ligrecap, colrecap + 2) = .Cells(1, 2)
End If
.Sort .Columns(8), xlAscending, Header:=xlNo 'tri des valeurs > 0
If .Cells(1, 8) <> "" Then
.Cells(1, 3).Interior.ColorIndex = 49: .Cells(1, 3).Font.ColorIndex = 6
.Cells(1, 3).Copy .Cells(rc - 16, 6)
.Cells(1, 2).Copy .Cells(rc - 17, 6)
If recap Then Frecap.Cells(ligrecap, colrecap + 3) = .Cells(1, 3): _
Frecap.Cells(ligrecap, colrecap + 4) = .Cells(1, 2)
End If
.Columns(7).Resize(, 2) = "" 'RAZ des colonnes auxiliaires
.Sort .Columns(1), xlAscending, Header:=xlNo 'tri dans l'ordre normal
'---mises en forme de la 1ère colonne---
With .Columns(1)
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
End With
'---bordures---
.Cells(lig, 2).Resize(rc, P.Columns.Count - 1).Borders.Weight = xlThin
lig = lig + rc
End If
Next i
ElseIf .Name = Frecap.Name Then
Application.ScreenUpdating = False
.[2:2,17:26].Replace "R*", "", xlWhole 'RAZ
.[3:12].ClearContents 'RAZ
recap = True
For Each Sh In Worksheets
If Sh.Name Like "TAB R#*" Then Workbook_SheetActivate Sh
Next Sh
recap = False
End If
ActiveCell.Select
With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub