Re,
Faut pas exagérer Guido, vous allez vous rendre malade
A+
Je suis un battant.lol
Private Sub Worksheet_Deactivate()
Dim i&, j&
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) Like "Course*" Then
With Range(Cells(i, 1), Cells(i + 6, 2).CurrentRegion)
For j = .Rows.Count + 4 To .Rows.Count + 2 Step -1
If .Cells(j, 2) = "" Then .Rows(j).EntireRow.Delete
Next j
End With
End If
Next i
With Me.UsedRange: End With 'actualise la barre de défilement
End Sub
'---
With .Range(.Cells(i, 2), .Cells(i + 6, 2).CurrentRegion)
.Resize(.Rows.Count + 1).EntireRow.Delete
End With
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, lig&, x$, i&, P As Range, j As Byte, k As Variant
Set F = Feuil2 'CodeNme
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
Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
P.Rows("1:8").Copy .Cells(lig, 1) 'début
P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
For j = 1 To 20 'milieu
k = Application.Match(j, P.Columns(2), 0)
If IsNumeric(k) Then P.Rows(k).Copy .Cells(lig + j + 7, 1)
.Cells(lig + j + 7, 1) = j
Next
'---mises en forme---
.Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlMedium
With .Cells(lig + 8, 1).Resize(20)
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
lig = lig + 38
End If
Next i
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 F As Worksheet, i&, lig&, x$, P As Range, j As Byte
Set F = Feuil2 'CodeNme
With Sh
If .Name Like "TAB R#*" Then
Application.ScreenUpdating = False
.Cells.Clear 'RAZ
i = Application.CountIf(F.Columns(2), ">20")
If i Then MsgBox i & " numéro(s) au delà de 20 en colonne B...": Exit Sub
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
Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
P.Rows("1:8").Copy .Cells(lig, 1) 'début
P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
For j = 9 To P.Rows.Count - 10 'milieu
If Val(P(j, 2)) > 0 Then P.Rows(j).Copy .Cells(lig + P(j, 2) + 7, 1)
Next
.Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlThin
If lig = 1 Then
'---mises en forme de la 1ère colonne---
With .Cells(lig + 8, 1).Resize(20)
.Cells(1) = 1
.DataSeries
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
Else
.Cells(9, 1).Resize(20).Copy .Cells(lig + 8, 1)
End If
lig = lig + 38
End If
Next i
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 F As Worksheet, i&, lig&, x$, P As Range, j As Byte, n&, n1, n2
Set F = Feuil2 'CodeNme
With Sh
If .Name Like "TAB R#*" Then
Application.ScreenUpdating = False
.Cells.Clear 'RAZ
i = Application.CountIf(F.Columns(2), ">20")
If i Then MsgBox i & " numéro(s) au delà de 20 en colonne B...": Exit Sub
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
Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
P.Rows("1:8").Copy .Cells(lig, 1) 'début
P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
For j = 9 To P.Rows.Count - 10 'milieu
n = lig + Val(P(j, 2)) + 7
If n > lig + 7 Then
n1 = Val(Replace(P(j, 4), ",", "."))
n2 = Val(Replace(P(j, 5), ",", "."))
P.Rows(j).Copy .Cells(n, 1)
.Cells(n, 3) = n1 - n2
.Cells(n, 4) = n1
.Cells(n, 5) = n2
End If
Next
.Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlThin
If lig = 1 Then
'---mises en forme de la 1ère colonne---
With .Cells(lig + 8, 1).Resize(20)
.Cells(1) = 1
.DataSeries
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
Else
.Cells(9, 1).Resize(20).Copy .Cells(lig + 8, 1)
End If
lig = lig + 38
End If
Next i
End If
ActiveCell.Select
With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub
Re,
Il ne faut pas utiliser de MFC ici.
A+
Il ne faut pas utiliser de MFC ici.
J'ai meme essayer de faire afficher le 1er plus petit moins et le 1er plus petit positif (...)
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim F As Worksheet, i&, lig&, x$, P As Range
Dim pn As Range, pp As Range, j As Byte, n&, n1, n2
Set F = Feuil2 'CodeNme
With Sh
If .Name Like "TAB R#*" Then
Application.ScreenUpdating = False
.Cells.Clear 'RAZ
i = Application.CountIf(F.Columns(2), ">20")
If i Then MsgBox i & " numéro(s) au delà de 20 en colonne B...": Exit Sub
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
Set P = F.Range(F.Cells(i, 1), F.Cells(i + 6, 2).CurrentRegion)
P.Rows("1:8").Copy .Cells(lig, 1) 'début
P.Rows(P.Rows.Count - 9).Resize(10).Copy .Cells(lig + 28, 1) 'fin
Set pn = Nothing 'premier plus petit négatif (en valeur absolue)
Set pp = Nothing 'premier plus petit positif
For j = 9 To P.Rows.Count - 10 'milieu
n = lig + Val(P(j, 2)) + 7
If n > lig + 7 Then
n1 = Val(Replace(P(j, 4), ",", "."))
n2 = Val(Replace(P(j, 5), ",", "."))
P.Rows(j).Copy .Cells(n, 1)
.Cells(n, 3) = n1 - n2
.Cells(n, 4) = n1
.Cells(n, 5) = n2
If pn Is Nothing And n1 - n2 < 0 Then Set pn = .Cells(n, 3)
If pp Is Nothing And n1 - n2 >= 0 Then Set pp = .Cells(n, 3)
If Not pn Is Nothing And n1 - n2 < 0 Then _
If n1 - n2 > pn Then Set pn = .Cells(n, 3)
If Not pp Is Nothing And n1 - n2 >= 0 Then _
If n1 - n2 < pp Then Set pp = .Cells(n, 3)
End If
Next j
'---pn et pp en colonne C---
.Cells(lig + 8, 3).Resize(20).Interior.ColorIndex = xlNone 'RAZ
.Cells(lig + 8, 3).Resize(20).Font.ColorIndex = xlAutomatic 'RAZ
If Not pn Is Nothing Then _
pn.Interior.ColorIndex = 3: pn.Font.ColorIndex = 6
If Not pp Is Nothing Then _
pp.Interior.ColorIndex = 49: pp.Font.ColorIndex = 6
'---bordures---
.Cells(lig, 2).Resize(38, P.Columns.Count - 1).Borders.Weight = xlThin
If lig = 1 Then
'---mises en forme de la 1ère colonne---
With .Cells(lig + 8, 1).Resize(20)
.Cells(1) = 1
.DataSeries
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
Else
.Cells(9, 1).Resize(20).Copy .Cells(lig + 8, 1)
End If
lig = lig + 38
End If
Next i
End If
ActiveCell.Select
With .UsedRange: End With 'actualise la barre de défilement
End With
End Sub