Guido
XLDnaute Accro
Bonjour Le Forum
J'aimerais suspendre la maco apres avoir terminé sont travail..
Je m'explique
Apres avoir changer les donnees sur la page prono je vais sur l'onglet Tab R1...puis 2....3...4..5
et pour finir onglet recap.
la le fichier est bien mis en place.
A ce moment j'aimerais qu'une nv macro bloque les onglet evenementielles ou les reactives..
Merci d'avance
Guido
Voici la macro
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim Frecap As Worksheet, F As Worksheet, arr, i&, lig&, x$, P As Range, rc As Byte
Dim colrecap%, ligrecap&, y$, t, j As Byte, rang As Variant
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
arr = Array(coul1, coul2, coul3, coul4, coul5)
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 '2ème tableau (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
If .Cells(j, 2).Interior.ColorIndex = 48 Then 'remplacement du gris foncé
.Cells(j, 2).Interior.ColorIndex = coul2
.Cells(j, 2).Font.ColorIndex = 6 'jaune
End If
rang = Application.Match(.Cells(j, 2).Interior.ColorIndex, arr, 0)
If IsNumeric(rang) Then t(j, 1) = rang Else t(j, 1) = ""
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 des arrivées
'---remplissage du 2ème tableau (arrivées)---
If recap Then
For j = 1 To 4
If .Cells(j, 1) = "" Or .Cells(j, 1) > 4 Then Exit For
Frecap.Cells(ligrecap + 14, colrecap + .Cells(j, 1)) = .Cells(j, 2)
Next j
End If
'---mise en forme de la 1ère colonne---
j = Application.Count(.Columns(1))
If j Then
With .Columns(1).Resize(j)
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
End If
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].Replace "R*", "", xlWhole 'RAZ
.[3:12,17:26].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
Merci
a plus
Guido
J'aimerais suspendre la maco apres avoir terminé sont travail..
Je m'explique
Apres avoir changer les donnees sur la page prono je vais sur l'onglet Tab R1...puis 2....3...4..5
et pour finir onglet recap.
la le fichier est bien mis en place.
A ce moment j'aimerais qu'une nv macro bloque les onglet evenementielles ou les reactives..
Merci d'avance
Guido
Voici la macro
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim Frecap As Worksheet, F As Worksheet, arr, i&, lig&, x$, P As Range, rc As Byte
Dim colrecap%, ligrecap&, y$, t, j As Byte, rang As Variant
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
arr = Array(coul1, coul2, coul3, coul4, coul5)
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 '2ème tableau (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
If .Cells(j, 2).Interior.ColorIndex = 48 Then 'remplacement du gris foncé
.Cells(j, 2).Interior.ColorIndex = coul2
.Cells(j, 2).Font.ColorIndex = 6 'jaune
End If
rang = Application.Match(.Cells(j, 2).Interior.ColorIndex, arr, 0)
If IsNumeric(rang) Then t(j, 1) = rang Else t(j, 1) = ""
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 des arrivées
'---remplissage du 2ème tableau (arrivées)---
If recap Then
For j = 1 To 4
If .Cells(j, 1) = "" Or .Cells(j, 1) > 4 Then Exit For
Frecap.Cells(ligrecap + 14, colrecap + .Cells(j, 1)) = .Cells(j, 2)
Next j
End If
'---mise en forme de la 1ère colonne---
j = Application.Count(.Columns(1))
If j Then
With .Columns(1).Resize(j)
.Borders.Weight = xlThin
.Interior.ColorIndex = 16 'gris
.Font.ColorIndex = 6 'jaune
.HorizontalAlignment = xlCenter
End With
End If
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].Replace "R*", "", xlWhole 'RAZ
.[3:12,17:26].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
Merci
a plus
Guido
