Option Compare Text
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As LongPtr) As Long
Public Const Attrib_Done = "þ"
Public Const Coché = "ü"
Sub Start_Mao()
Application.DisplayFullScreen = True
Start_Onkey
Start_Usf
If [JOUEURS_REGULIERS].Cells(1) = "" Then APPEL_LISTE
End Sub
Sub Start_Usf()
Usf_Mao_Ds.Show 0
End Sub
Sub Start_Onkey()
Application.OnKey "^f", "Start_Usf" ' ctrl+f
Application.OnKey "^s", "Save_Xltm" ' ctrl+s
Application.OnKey "^o", "Svg_Stop" ' ctrl+o
Svg_Start
End Sub
Sub Close_Mao()
ThisWorkbook.BuiltinDocumentProperties("Comments") = ""
Application.OnKey "^f"
Application.OnKey "^s"
Application.OnKey "^o"
Svg_Stop
End Sub
Sub Svg_Clean()
N = 15: Mdate = Date - N ' On garde n jours max de sauvegardes
Set Fso = CreateObject("Scripting.FileSystemObject")
For Each SVG In Fso.getfolder(ThisWorkbook.Names("Svg_Dir").RefersToRange).subfolders
If Mdate > SVG.datecreated Then SVG.Delete
Next
Set Fso = Nothing
End Sub
Sub Svg_Stop()
On Error Resume Next
With ThisWorkbook
If IsDate(.Names("Svg_Next").RefersToRange) Then
Application.EnableEvents = False
Application.OnTime .Names("Svg_Next").RefersToRange, "Svg_Run", , False
.Names("Svg_Next").RefersToRange.ClearContents
Application.EnableEvents = True
End If
End With
End Sub
Sub Svg_Start()
With ThisWorkbook
Select Case True
Case .Names("Svg_Intvl").RefersToRange <= 0: ' On ne lance pas
Case Not IsDate(.Names("Svg_Next").RefersToRange)
Application.EnableEvents = False
T = TimeValue("00:" & Format(.Names("Svg_Intvl").RefersToRange, "00") & ":00")
.Names("Svg_Next").RefersToRange = Now + T ' Toutes les Svg_Intvl minutes
Application.OnTime .Names("Svg_Next").RefersToRange, "Svg_Run"
Application.EnableEvents = True
End Select
End With
End Sub
Sub Svg_Run()
Dim SVG As String, Target As String
With ThisWorkbook
If IsDate(.Names("Svg_Next").RefersToRange) Then
Application.EnableEvents = False
Application.ScreenUpdating = False
Do While Dir(.Names("Svg_Dir").RefersToRange, vbDirectory) = "": Get_Folder_Svg: Loop
Target = .Names("Svg_Dir").RefersToRange & "\" & .Names("Suffixe").RefersToRange & " " & Format(.Names("Date_Concours").RefersToRange, "dd-mm-yyyy") & "\"
If Dir(Target) = "" Then MkDir Target
SVG = Target & Format(Now, "hh_mm") & ".xlsm"
If SVG = ThisWorkbook.FullName Then
ActiveWorkbook.Save
Else
[E1].Value = [E1].Value 'FIGER la date d'AUJOURDHUI
[A1].Select
Application.DisplayAlerts = False
.SaveAs Filename:=SVG, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
End If
If IsDate(.Names("Svg_Next").RefersToRange) Then .Names("Svg_Next").RefersToRange.ClearContents
Start_Onkey
Application.EnableEvents = True
End If
End With
End Sub
Sub Save_Xltm()
Application.DisplayAlerts = False
Worksheets("Inscrip").Activate
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim Filename As Variant
Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
With Dlg
.AllowMultiSelect = False
.Title = "Dossier de Lancement (XLTM)"
.InitialFileName = [Root] & "*.xltm"
.Filters.Clear
.Filters.Add "Fichier de lancement", "*.xltm"
If .Show Then
Application.EnableEvents = False
DEVERROU
[E1].FormulaR1C1 = "=TODAY()"
RAZ vbYes
Application.EnableEvents = True
Cur_File = ThisWorkbook.FullName
xlt_file = .SelectedItems(1)
ThisWorkbook.SaveAs Filename:=xlt_file, FileFormat:=xlOpenXMLTemplateMacroEnabled
Set Wb_Xlt = ActiveWorkbook
D = InStrRev(xlt_file, "\")
MsgBox Mid(xlt_file, D + 1) & vbTab & "Saved Err=" & Err.Number, vbOKOnly + vbInformation, Left(xlt_file, D - 1)
Workbooks.Open Cur_File ' On ré-ouvre le classeur avant la copie modèle
Wb_Xlt.Close False
End If
End With
Set Dlg = Nothing
Application.DisplayAlerts = True
End Sub
Sub Print_Preview()
Dim S_Ad As Boolean
S_Ad = Application.DisplayFullScreen
Application.DisplayFullScreen = False
Usf_Mao_Ds.Hide
ActiveWindow.SelectedSheets.PrintPreview
Usf_Mao_Ds.Show
Application.DisplayFullScreen = S_Ad
End Sub
Sub Effacer()
Application.EnableEvents = False
Set R = Worksheets("Inscrip").Rows(4).Find("Tour " & [Tour])
If Not R Is Nothing Then
Colonne = R.Column
For Each Joueur In [Equipes].Rows(1).Cells ' les rows sont mergées
If Joueur > 0 Then
Set R = [TRI_RESU].Columns(1).Find(Joueur)
Worksheets("Inscrip").Cells(R.Row, Colonne).ClearContents
End If
Next
End If
[Equipes].Parent.Charge_Cbx_Text
Application.EnableEvents = True
End Sub
Sub TRI_RESU_P_GAGNEES()
If MsgBox("ATTENTION :" & vbLf & _
"Cette étape nécessite d'avoir enregistré" & vbLf & _
"TOUS LES RESULTATS de TOUS les tours de jeu " & vbLf & _
"(voir feuille 'NOTER 1 RESULTAT' en E3 à H3)." & vbLf & vbLf & _
UCase("AVEZ-VOUS ENREGISTRé TOUS LES RESULTATS ?"), _
vbCritical + vbYesNo, _
"VALIDER pour CONTINUER.") = vbYes Then
Svg_Run 'svg, AVANT TRI, forcée par sécurité
[R23] = 1 'en jaune si =1 car le tri a été fait ==> les N° sont le classement : voir variable trié§ = _(avant_tri)
Application.Goto Reference:="TRI_RESU"
DEVERROU
[TRI_RESU].Resize([NBJR]).Sort _
Key1:=Range("L5"), Order1:=xlDescending, DataOption1:=xlSortTextAsNumbers, _
Key2:=Range("P5"), Order2:=xlDescending, DataOption2:=xlSortNormal, _
Key3:=Range("D5"), Order3:=xlAscending, DataOption3:=xlSortNormal, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
VERROU
Range("A1").Select
End If
End Sub
Sub IMPRIMER_RESU()
Dim C As Range
Const Delim = vbTab
CADRER_INSCRIP
DEVERROU
Application.EnableEvents = False
' On rajoute le n° de mobile en commentaire au nom
Set C = [TRI_RESU].Find("*", , xlComments)
Do While Not C Is Nothing
If s_address = "" Then s_address = C.Address
C.Value = C.Value & Delim & C.Comment.Text
Set C = [TRI_RESU].Find("*", C, xlComments)
If C.Address = s_address Then Set C = Nothing
Loop
ActiveSheet.PageSetup.PrintArea = "$B$1:$Q$135" ' = Zone "IMPRIM_RESULTAT"
With ActiveSheet.PageSetup
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
End With
If Usf_Mao_Ds.Visible Then Usf_Mao_Ds.Hide
Print_Preview
Usf_Mao_Ds.Show
' On enlève le n° de mobile en commentaire au nom
Set C = [TRI_RESU].Find("*", , xlComments)
s_address = ""
Do While Not C Is Nothing
If s_address = "" Then s_address = C.Address
C.Value = Split(C.Value, Delim)(0)
Set C = [TRI_RESU].Find("*", C, xlComments)
If C.Address = s_address Then Set C = Nothing
Loop
' Range("A1").Select
Application.EnableEvents = True
VERROU
End Sub
Sub Imp_Tirage(Optional Plage)
If IsMissing(Plage) Then
Plage_List = Array("*", [C28], [I28], [O28], [U28])
N = Split(Application.Caller, "_")(2)
If N > 0 Then
Set Plage = Plage_List(N)
Else
For N = 1 To 4
Imp_Tirage Plage_List(N)
Next
Exit Sub
End If
End If
Dim Text As String
Dim I As Integer, LC As Integer, LR As Integer
Application.ScreenUpdating = False
F_Chiffres = 60
F_Noms = 40
F_Cadres = 30
F_Color = Cells(8, Plage.Column).Interior.Color
Set R = Columns(Plage.Column).Rows(Rows.Count).End(xlUp)
Set Plage = Range(Plage, R).Resize(, 6)
On Error Resume Next
Worksheets("ImpMao").Visible = True
If Err() > 0 Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "ImpMao"
Worksheets("ImpMao").Activate
Cells.Delete
ActiveWindow.Zoom = 55
Plage.Copy
Range("D1").PasteSpecial xlPasteValues
Selection.Interior.Color = F_Color
Selection.HorizontalAlignment = xlCenter
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
On Error GoTo 0
Cells.Font.Name = "Segoe UI"
Cells.Font.Size = F_Chiffres
Cells.VerticalAlignment = xlCenter
With Columns("A").Cells(1) ' Colonne Terrain
.Value = "Terrain"
.Font.Size = F_Cadres
.VerticalAlignment = xlBottom
End With
For Each C In Array("B", "K") ' colonnes Noms
With Columns(C)
.ColumnWidth = 200
.Font.Size = F_Noms
.HorizontalAlignment = xlRight
End With
Next
For Each C In Array("C", "J") ' colonnes Score
With Columns(C).Cells(1)
.Value = "Score"
.Font.Size = F_Cadres
.VerticalAlignment = xlBottom
End With
Next
LR = ActiveSheet.UsedRange.Rows.Count
LC = Columns("K").Column
Cells(1, 1).Resize(, LC).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A2:A" & LR).Borders(xlEdgeLeft).LineStyle = xlContinuous
For I = LR To 2 Step -1
' If I = 3 Then Stop
Select Case True
Case Cells(I, 4) Like "Blanc*"
If Cells(I, 6) > 0 Then
Set_Joueurs I, 4, 2
Cells(I, 9).ClearContents
Cells(I, 4).Resize(, 2).Merge
Cells(I, 4) = "Blanc:"
Cells(I, 1).Resize(, LC).Borders(xlEdgeBottom).LineStyle = xlContinuous
Else
Cells(I, 4).EntireRow.Delete
End If
Case Cells(I, 4) > 0
Set_Joueurs I, 4, 2
Set_Joueurs I, 7, 11
Cells(I, 1).Resize(, LC).Borders(xlEdgeBottom).LineStyle = xlContinuous
Case Else
Cells(I, 4).EntireRow.Delete
End Select
Next
LR = ActiveSheet.UsedRange.Rows.Count
With Range("D1:I" & LR)
.BorderAround xlContinuous, xlThick
With .Rows(1)
.Merge
.HorizontalAlignment = xlCenter
.BorderAround xlContinuous, xlThick
.Font.Bold = True
End With
End With
Columns("G").Insert Shift:=xlToRight
With Columns("G")
.Interior.Pattern = xlNone
.ColumnWidth = 2
End With
If WorksheetFunction.CountA([J:J]) = 0 Then Columns("J").ColumnWidth = 1
If WorksheetFunction.CountA([F:F]) = 0 Then Columns("F").ColumnWidth = 1
Range("A:D").Columns.AutoFit
Range("K:L").Columns.AutoFit
[A1:L1].Interior.Color = F_Color
Application.PrintCommunication = False
Application.ScreenUpdating = True
With ActiveSheet.PageSetup
.PrintArea = "A1:L" & LR
.PrintTitleRows = "R1"
.LeftMargin = 10: .RightMargin = 10
.TopMargin = 10: .BottomMargin = 10
.HeaderMargin = 0: .FooterMargin = 0
.PrintHeadings = False: .PrintGridlines = False: .PrintComments = xlPrintNoComments
.CenterHorizontally = True: .CenterVertically = False
.Orientation = xlPortrait: .PaperSize = xlPaperA4
.FitToPagesWide = 1: .FitToPagesTall = False
End With
Application.PrintCommunication = True
If Usf_Mao_Ds.Visible Then Usf_Mao_Ds.Hide
Print_Preview
Worksheets("Tirages").Activate
Worksheets("ImpMao").Visible = False
Usf_Mao_Ds.Show
End Sub
Sub Set_Joueurs(I As Integer, J As Integer, K As Integer)
Dim Text As String
Dim Found As Range
Text = ""
For J = J + 2 To J Step -1
If Val(Cells(I, J)) > 0 Then
Set Found = [TRI_RESU].Columns(1).Find(Cells(I, J), , xlValues, xlByRows)
Text = Found.Offset(, 2) & vbLf & Text
' If Found.Offset(, 3) = "F" Then Stop
If Found.Offset(, 3) = "F" Then Cells(I, J).Interior.Color = 16764159 ' Femme
Else
Cells(I, J).ClearContents
End If
Next
' On Error Resume Next
Cells(I, K) = Application.WorksheetFunction.Proper(Left(Text, Len(Text) - 1))
Cells(I, K).BorderAround xlContinuous
End Sub
Sub EnEvents()
MsgBox "Events=" & Application.EnableEvents
Application.EnableEvents = True
End Sub
Sub Enlever_Filtre()
Usf_Mao_Ds.Tbx_Régulier = vbNullString
End Sub
Sub Inscrip_Change(ByVal Target As Range)
Dim Cell As Range
Application.EnableEvents = False
For Each Cell In Target.Cells
Select Case True
Case Cell.Address = Worksheets("Inscrip").[Svg_Intvl].Address
Svg_Stop
[Svg_Next].ClearContents
Svg_Start
Case Not Intersect(Cell, [Zone_Payé]) Is Nothing
'If Cell <> vbNullString Then
nbg = Val(Cell.Offset(, -5))
Select Case Cell.Offset(, -5)
Case "": Cell = ""
Case 0: Cell = Chr(150)
Case Else: Cell = Chr(145) & nbg
End Select
Cell.Characters(Start:=2, Length:=1).Font.Name = "Calibri"
Cell.ShrinkToFit = True
Cell.HorizontalAlignment = xlGeneral
Cell.VerticalAlignment = xlBottom
Cell.WrapText = False
'End If
Case Not Intersect(Cell, Worksheets("Inscrip").[D2]) Is Nothing _
And Target.Count = 1 ' Formule de jeu
VALIDER_formule
Case Not Intersect(Cell, [A_inscrire_si_1]) Is Nothing
If [Tirage_Done] = "Ok" Then
If MsgBox("Le tirage a été fait" & vbLf & _
"Voulez-vous le casser ?", _
vbCritical + vbQuestion + vbYesNo) = vbYes Then
[Tirage_Done] = ""
[Attrib] = False
Else
Cell = IIf(Cell = Coché, "", Coché)
Exit For
End If
End If
If Cell <> "" And Cell <> Coché Then Cell = Coché
Case Not Intersect(Cell, [Ordre_Liste]) Is Nothing _
And Target.Count = 1 ' Formule de jeu
If Target = vbNullString _
Then Application.Undo _
Else Tri_Joueurs_Reguliers
Case Not Intersect(Cell, [Joueurs_en_D5].Columns(1).Cells) Is Nothing
' Un joueur en zone D5 a été modifié manuellement
If Cell = "" Then 'Joueur supprimé
If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
Cell.Offset(, 1).ClearContents
' Le joueur a été supprimé, on doit remonter tous les suivants
If Cell.Offset(1) <> "" Then
Cell.Offset(1).Resize(, 2).Copy
Cell.PasteSpecial xlPasteValues
Cell.PasteSpecial xlPasteComments
Application.EnableEvents = True
Cell.Offset(1).Resize(, 2).ClearContents
Application.EnableEvents = False
End If
' Set R = [Joueurs_Reguliers].Find(Old_Man, , xlValues, xlWhole)
' If Not R Is Nothing Then R.Offset(, -2) = ""
Else
Do While InStr(Cell.Value, " "): Cell.Value = Replace(Cell.Value, " ", ""): Loop
Cell.Value = Trim(Replace(StrConv(Replace(Cell.Value, "-", "- "), vbProperCase), "- ", "-"))
Set R = [Joueurs_en_D5].Find(Cell.Value, , xlValues, xlWhole, xlByColumns, xlNext, False, False)
If Not R Is Nothing Then 'le joueur entré est en double
If R.Address <> Cell.Address Then
MsgBox Cell.Value & vbLf & " est déjà inscrit", vbExclamation + vbOKOnly
Cell.ClearContents
Exit For
End If
End If
Set R = [JOUEURS_REGULIERS].Columns(1).Find(Cell.Value, , xlValues, xlWhole, xlByColumns, xlNext, False, False)
If Not R Is Nothing Then ' le nom entré est un joueur régulier
R.Offset(, -2) = Coché
Cell.Offset(, 1) = R.Offset(, 1)
MsgBox Cell.Value & vbLf & " est un joueur régulier", vbInformation + vbOKOnly
If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
Else ' joueur externe
DEVERROU ' Indispensable pour ajouter un commentaire
If Cell.Comment Is Nothing Then Cell.AddComment
mobile = InputBox("N° de Mobile ou de Licence :", "Joueur externe " & Cell, Cell.Comment.Text)
Cell.Comment.Text IIf(mobile = "", "Externe", mobile)
Cell.Comment.Shape.TextFrame.AutoSize = True
Cell.Offset(, 1) = "M"
VERROU
End If
End If
L = Application.WorksheetFunction.CountA([Joueurs_en_D5].Columns(1))
If [Joueurs_en_D5].SpecialCells(xlCellTypeVisible).Rows.Count = L _
Then [Joueurs_en_D5].RowHeight = 28.5
Case Not Intersect(Cell, [JOUEURS_REGULIERS]) Is Nothing
If Target.Count = 1 Then Application.Undo
Case Not Intersect(Cell, [A_inscrire_si_1]) Is Nothing
If Target.Count = 1 And Cell.Offset(, 2) = "" Then Application.Undo
End Select
Next
Application.EnableEvents = True
End Sub
'Sub AJOUTER_NOM()
'Dim Lig As Integer
'If Trim([D4]) <> vbNullString Then
' MsgBox [Joueurs_En_d5].Row
' Lig = [NBJR] + 5 '1ère ligne libre
' If Lig >= 30 Then AJOUTER_JRS
'
' Range("D" & Lig) = [D4]
' Set F = [Joueurs_reguliers].Columns(1).Find([D4], , xlValues)
' If Not F Is Nothing Then
' Range("E" & Lig) = F.Offset(0, 1)
' Else
' mobile = InputBox("N° de Mobile:")
' Range("D" & Lig).AddComment mobile
' Range("D" & Lig).Comment.Shape.TextFrame.AutoSize = True
' Range("E" & Lig).Select
' Selection.Value = "M"
' End If
' [D4].ClearContents
' VERROU
'End If
'
'End Sub
'Sub AJOUTER_JRS()
' [Joueurs_En_d5].RowHeight = 28.5
'End Sub
Sub ATTRIB_NUM()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim Title As String
Worksheets("INSCRIP").Activate
If ActiveSheet.FilterMode Then Enlever_Filtre
REPORT_DES_NOMS_AVEC_1 ' on force ce report car l'ordre a pu changer entre temps
Select Case True
Case Application.WorksheetFunction.CountA([Joueurs_en_D5].Columns(1)) < 8 '12
MsgBox "Trop peu de joueurs pour un tirage efficace", vbCritical + vbOKOnly
Exit Sub
Case [Attrib]
If MsgBox("L'affectation des N° est déjà faite !" & vbLf & vbLf & _
"(à refaire si un nom a été rajouté)" & vbLf & vbLf & _
"Voulez-vous refaire l'attribution ?", vbExclamation + vbYesNo, "Attribution") = vbNo Then
Exit Sub
Else
[Attrib] = False
End If
End Select
Title = "VALIDER pour CONTINUER"
If [Formule] = 2 Then 'cas doublettes maximoises :
If Range("S3") = 0 Then 'cas doublettes maximoises et trop de Femmes : CAS=0
If MsgBox(Range("T4") & vbLf & " OK ? ", _
vbQuestion & vbYesNo) <> vbYes Then Exit Sub
End If
Else
If MsgBox("Préparation de la liste des équipes :" & vbLf & _
"Voulez-vous donner aux équipes un N° " & vbLf & _
"DIFFERENT de celui de l'ORDRE D'INSCRIPTION ?" & vbLf & vbLf & _
"Répondre NON si étiquettes déjà distribuées.", vbQuestion + vbYesNo, Title) <> vbYes Then GoTo Listes
End If
[Tirage_Done].ClearContents
[Tours_Resultats].ClearContents
Worksheets("Noter 1 RESULTAT").Cbx_Noms.Clear
[TRI_noms].Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Listes:
' on masque les colonnes C et G
Columns("C").Hidden = True
Columns("G").Hidden = True
[Attrib] = True
'****************** transfert en fixe + tri num puis copie pour TRI alpha
[Joueurs_en_D5].Copy: [AL5].PasteSpecial Paste:=xlPasteValues
[AK5].Resize([Joueurs_en_D5].Rows.Count, 2).Copy: [AC5].PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
' Tri des Noms de la liste Alpha
[AC5].Resize([Joueurs_en_D5].Rows.Count, 2).Sort _
Key1:=Range("AD5"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
Key2:=Range("AC5"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
Header:=xlNo, Orientation:=xlTopToBottom
' Les numéros étant attribués les "NOMS" sont figés et
' protégés des fausses manoeuvres (sauf si on déverrouille la feuille)
With [Joueurs_en_D5]
.Locked = True
.FormulaHidden = False
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Usf_Mao_Ds.Show_Repaint
End Sub
Sub DEVERROU(Optional Sh As Worksheet)
' ATTENTION l'unprotect fait perdre le contenu du COPY
If Sh Is Nothing Then Set Sh = ActiveSheet
Sh.Unprotect
Set Sh = Nothing
End Sub
Sub VERROU(Optional Sh As Worksheet)
If Not [NoLock] Then
If Sh Is Nothing Then Set Sh = ActiveSheet
Sh.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, UserInterfaceOnly:=True
Set Sh = Nothing
End If
End Sub
Sub Saisir_En_D5(Optional Ajouter As Boolean = True)
CADRER_INSCRIP
Select Case True
Case [NBJR] >= 131: MsgBox "Nombre maximum de joueurs atteint", vbCritical + vbOKOnly
Case Not Ajouter
Case Else
If [Tirage_Done] = "OK" Then _
If MsgBox("Tirage effectué" & vbLf & _
"Ajouter un joueur quand même ?", vbCritical + vbOKCancel) = vbCancel Then Exit Sub
With [Joueurs_en_D5].SpecialCells(xlCellTypeBlanks).Cells(1)
.Rows.Hidden = False
.Select
End With
Usf_Mao_Ds.Cmd_Add_Click
End Select
End Sub
Function Get_File_Liste() As Boolean
Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
With Dlg
.AllowMultiSelect = False
.Title = "Dossier des Joueurs Habituels"
.InitialFileName = [Dir_Liste] & "\" & [Nom_Liste] & ".xls"
.Filters.Clear
.Filters.Add "Liste(s) des joueurs", "*.xls"
.Show
If .SelectedItems.Count > 0 Then
Z = Dir(.SelectedItems(1))
[Nom_Liste] = Left(Z, InStrRev(Z, ".") - 1)
[Dir_Liste] = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), Application.PathSeparator) - 1)
Get_File_Liste = True
Else
Get_File_Liste = False
End If
End With
Set Dlg = Nothing
End Function
Sub CADRER_A_INSCRIRE()
Application.Goto [Zone_Réguliers], True
[A_inscrire_si_1].Cells(1).Activate
End Sub
Sub GOTO_NOTER()
If Not [Attrib] Then
MsgBox "Les numéros n'ont pas été attribués", vbCritical
Else
Worksheets("Noter 1 RESULTAT").Activate
End If
End Sub
Sub VOIR_TABL_N() ' en provenance de "INSCRIP"
If Not [Attrib] Then
MsgBox "Les numéros n'ont pas été attribués", vbCritical
Exit Sub
End If
If Range("E141") >= 1 And Not [Attrib] Then 'Fem+Z>=1 et TRI déjà fait
If MsgBox(Title:="VALIDER pour CONTINUER.", _
Prompt:="Cette étape nécessite d'avoir au préalable cliqué sur 'ATTRIBUER 1 N° à chaque joueur'" & _
" (par tirage au sort) sinon les N° resteront dans l'ordre des inscriptions" & _
" et surtout les informations de la colonne 'SEXE' resteront inefficaces !!! Voulez-vous néanmoins CONTINUER ?" _
, Buttons:=4) <> 6 Then
MsgBox "Alors veuillez SVP cliquer sur le bouton '5. ATTRIBUER 1 N° ... " & vbLf & _
" puis recommencer votre dernière opération seulement. MERCI."
Exit Sub
End If
End If
Application.ScreenUpdating = False
Svg_Run 'sauvegarde forcée par sécurité
[NT] = Worksheets("INSCRIP").Range("L1") 'transfert du NB JRS en NT
Worksheets("Noter 1 RESULTAT").Cbx_Noms.Clear
TRANSFERT
If [Formule] <> 2 Then MAJ_BLANCS
CADRER_TIRAGES
End Sub
Sub Tirage_COL67()
With Worksheets("TIRAGES") ' pour appel depuis INSCRIP bouton 7 "vers TOUR de JEU"
.Columns("I:N").ColumnWidth = 0
.Columns("U:Z").ColumnWidth = 0
.Columns("AG:AL").ColumnWidth = 0
.Columns("AS:AX").ColumnWidth = 0
End With
End Sub
Sub Tirage_COL131()
With Worksheets("TIRAGES") ' pour appel depuis INSCRIP bouton 7 "vers TOUR de JEU"
.Columns("I:N").ColumnWidth = 2.71
.Columns("U:Z").ColumnWidth = 2.71
.Columns("AG:AL").ColumnWidth = 2.71
.Columns("AS:AX").ColumnWidth = 2.71
End With
End Sub
Sub Tmfc()
DEVERROU ' Nécessaire pour les MFC
For I = Worksheets("Tirages").Cells.FormatConditions.Count To 1 Step -1
With Worksheets("Tirages").Cells.FormatConditions(I)
If .Font.Strikethrough Then Debug.Print .Formula1
End With
Next
End Sub
Sub TRANSFERT() '[NT] (de feuille TIRAGES) est supposé alimenté et >=8 sinon nn négatif
Application.ScreenUpdating = False
Worksheets("Tirages").Visible = True
Worksheets("Tirages").Activate
[TIRAGE_appelé].FormulaR1C1 = ""
Range("C25") = Range("A22") 'valeur initiale nb Fem mises en relief ?
'************* CALCUL ADR du tableau à copier
Dim nn As Integer, lig_suppl As Integer, taille As Integer, DECAL_30 As Integer
DECAL_30 = IIf(Worksheets("INSCRIP").Range("S3") = 2, 30, 0) 'décalage de 30 colonnes pour accéder à la variante en F2
If [NT] > 68 And [Formule] = 2 Then Tirage_COL131 Else Tirage_COL67
Tirage_COL131
If [NT] >= 68 And [Formule] = 2 Then
lig_suppl = ([NT] - 68) * 16
taille = 21 + 16
Else
lig_suppl = 0
taille = 21
End If
nn = 22 * [NT] - 176 + lig_suppl
'************* FIN du CALCUL ADR du tableau à copier
' Comme on va copier toute une plage du fichier des tables,
' les MFC en cours risquent d'être découpées au profit de celles de la plage copiée
' On les détruit
' DEVERROU ' Nécessaire pour les MFC
' For I = Worksheets("Tirages").Cells.FormatConditions.Count To 1 Step -1
' With Worksheets("Tirages").Cells.FormatConditions(I)
' If .Font.Strikethrough Then .Delete
' End With
' Next
'******************ouverture fichier TABLE concernée et copy :
Set Fso = CreateObject("Scripting.FileSystemObject")
Do While Not Fso.FolderExists([Dir_Tables])
Get_Folder_Tables
Loop
Set Fso = Nothing
With Workbooks.Open(Filename:=[Dir_Tables] & "\" & [Nom_TABLE], ReadOnly:=True)
Application.EnableEvents = False
Worksheets("F2").Range(Cells(1 + nn, 1 + DECAL_30), Cells(taille + nn, 26 + DECAL_30)).Copy
' ThisWorkbook.Worksheets("Tirages").Range("A27").PasteSpecial xlPasteAll
ThisWorkbook.Worksheets("Tirages").Range("A27").PasteSpecial xlPasteFormulas
Application.CutCopyMode = False
.Close SaveChanges:=False
Application.EnableEvents = True
End With
'supprimer lignes 5 et/ou 6 et/ou 7 inutiles car VIDES
If Range("E5") = 0 Then Rows(5).RowHeight = 0
If Range("C6") = 0 Then Rows(6).RowHeight = 0
If Range("C7") = 0 Then Rows(7).RowHeight = 0
' On reconstitue les MFC pour le suivi des parties terminées
Worksheets("Tirages").Mfc_TIRAGES
' DEVERROU ' Nécessaire pour les MFC
' On Error Resume Next
' Pl = Array("C30", "I30", "O30", "U30")
' L = [Tour_1].Rows.Count - 2
' For I = 0 To UBound(Pl)
' f = "RECHERCHEV(" & Pl(I) & ";TRI_RESU;" & I + 7 & ")"
' With Range(Pl(I)).Resize(L, 6).FormatConditions.Add(Type:=xlExpression, _
' Formula1:="=OU(" & f & "=""G"";SI(ESTNUM(" & f & ");" & f & ">0;FAUX))")
' .Font.Strikethrough = True
' .Font.Color = vbRed
' .Interior.Color = 14277081
' .StopIfTrue = False
' .SetFirstPriority
' End With
' With Range(Pl(I)).Resize(L, 6).FormatConditions.Add(Type:=xlExpression, _
' Formula1:="=OU(" & f & "=""P"";SI(ESTNUM(" & f & ");" & f & "<0;FAUX))")
' .Font.Strikethrough = True
' '.Font.Color = vbRed
' .Interior.Color = 14277081
' .StopIfTrue = False
' .SetFirstPriority
' End With
' Next
' Re-init noter un résultat
Application.EnableEvents = False
[N_Joueur] = 1
[Tour] = 1
Application.EnableEvents = True
Is_Tirage_Done
Range("C1").Select
Usf_Mao_Ds.Show_Repaint
End Sub
Sub Edit_Liste()
Dim NomListe As String
NomListe = [Nom_Liste].Value & ".xls"
Set Fso = CreateObject("Scripting.FileSystemObject")
Do While Not Fso.FileExists([Dir_Liste] & "\" & NomListe)
Get_File_Liste
Loop
Set Fso = Nothing
NomListe = [Nom_Liste].Value & ".xls"
Msgtext = NomListe & " est ouvert en écriture" & vbLf & vbLf & _
"Si vous le modifiez," & vbLf & _
"n'oubliez pas de recharger la liste dans DS Pétanque"
On Error Resume Next
If Workbooks(NomListe) Is Nothing Then
Workbooks.Open ([Dir_Liste] & "\" & [Nom_Liste])
Else
Workbooks(NomListe).Activate
End If
Workbooks(NomListe).Worksheets("Modif").Unprotect
MsgBox Msgtext, vbInformation + vbOKOnly, "Liste des joueurs Habituels"
End Sub
Sub S_APPEL_LISTE()
If MsgBox("Etes-vous sûr(e) de vouloir recharger la liste des habitué(e)s ?", vbCritical + vbYesNo) = vbYes Then
If WorksheetFunction.CountA([A_inscrire_si_1]) = 0 Then
APPEL_LISTE
Else
APPEL_LISTE MsgBox("Avec préservation des Inscrits ?", vbQuestion + vbYesNo) = vbYes
End If
End If
End Sub
Sub APPEL_LISTE(Optional Preserver As Boolean = False)
Dim Joueurs_Inscrits
Dim R As Range
Dim F_Address As String
Dim Fso As Object
Application.ScreenUpdating = False
' Intégration de la liste des joueurs
Set Inscrip = ThisWorkbook.Worksheets("Inscrip")
Enlever_Filtre
Set Fso = CreateObject("Scripting.FileSystemObject")
Do While Not Fso.FileExists([Dir_Liste] & "\" & [Nom_Liste] & ".xls")
Get_File_Liste
Loop
Set Fso = Nothing
If Preserver Then
' sauvegarde des joueurs inscrits
Set Joueurs_Inscrits = CreateObject("Scripting.Dictionary")
F_Address = ""
Set R = [A_inscrire_si_1].Columns(1).Cells([A_inscrire_si_1].Rows.Count)
' on cherche les joueurs cochés
Set R = [A_inscrire_si_1].Find(Coché, R, xlValues, xlWhole, xlByColumns, xlPrevious)
Do While Not R Is Nothing
If F_Address = "" Then F_Address = R.Address
Joueurs_Inscrits.Add R.Offset(, 4) & " " & R.Offset(, 5), 1
Set R = [A_inscrire_si_1].FindPrevious(R)
If R.Address = F_Address Then Set R = Nothing
Loop
End If
Application.EnableEvents = False
[A_inscrire_si_1].FormulaR1C1 = ""
[JOUEURS_REGULIERS].EntireRow.Hidden = False
[JOUEURS_REGULIERS].Offset(, 1).ClearContents
Filename = [Dir_Liste] & "\" & [Nom_Liste] & ".xls"
With Workbooks.Open(Filename:=Filename, ReadOnly:=True)
[Inscrits[#Data]].Copy
Inscrip.Range("E147").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
.Close SaveChanges:=False
End With
Application.EnableEvents = True
If Preserver Then
For Each Joueur In Inscrip.Range("F" & 147 & ":G" & [A_inscrire_si_1].Rows.Count).Rows
If Joueurs_Inscrits.exists(Joueur.Cells(1) & " " & Joueur.Cells(2)) Then Range("B" & Joueur.Row) = "1"
Next
Set Joueurs_Inscrits = Nothing
End If
Tri_Joueurs_Reguliers
[JOUEURS_REGULIERS].Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
Usf_Mao_Ds.Tbx_Régulier_Change
Application.Goto Inscrip.[B144], True
Set Inscrip = Nothing
End Sub
Function Get_Folder_Tables() As Boolean
Dim Fd As FileDialog
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
With Fd
.AllowMultiSelect = False
.Title = "Dossier des Tables de Tirages"
.InitialFileName = [Dir_Tables].Value & IIf(Right([Dir_Tables], 1) = "\", "", "\")
.Show
If .SelectedItems.Count > 0 Then
Application.EnableEvents = False
[Dir_Tables].Value = .SelectedItems(1)
Application.EnableEvents = True
Get_Folder_Tables = True
Else
Get_Folder_Tables = False
End If
End With
Set Fd = Nothing
End Function
Function Get_Folder_Svg() As Boolean
Dim Fd As FileDialog
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
With Fd
.AllowMultiSelect = False
.Title = "Dossier des Sauvegardes [ RESULTATS ]"
.InitialFileName = [Svg_Dir].Value & IIf(Right([Svg_Dir], 1) = "\", "", "\")
.Show
If .SelectedItems.Count > 0 Then
Application.EnableEvents = False
[Svg_Dir].Value = .SelectedItems(1)
Application.EnableEvents = True
Get_Folder_Svg = True
Else
Get_Folder_Svg = False
End If
End With
Set Fd = Nothing
End Function
Sub RAZ_Joueurs_Réguliers_Inscrits()
[A_inscrire_si_1].ClearContents
End Sub
Sub RAZ(Optional SansConfirmer = vbNo)
If SansConfirmer = vbNo Then _
SansConfirmer = MsgBox("Voulez-vous lancer" & vbLf & "l'effacement de la liste", _
vbYesNo + vbQuestion, _
"VALIDER pour CONTINUER")
If SansConfirmer = vbYes Then
Application.EnableEvents = False
Application.ScreenUpdating = False
[E1].FormulaR1C1 = "=TODAY()" 'initialiser avec date=AUJOURDHUI
[AL5:AL135].FormulaR1C1 = "=IF(RC[-34]="""","""",RC[-34])"
[AC5:AD135].ClearContents
[RAZ_LISTE].ClearContents
[NT] = vbNullString
[TIRAGE_appelé].ClearContents
[R23].ClearContents
For Each Cell In [Joueurs_en_D5].Cells
If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
Next
' on peut saisir directement (jusqu'à atrribution des N°) en D5 à E135, même si la feuille est verrouillée.
[Zone_Payé].Locked = False
[D5:E135].Locked = False
[D5:E135].FormulaHidden = False
APPEL_LISTE ' On recharge la liste des joueurs habitués
REDUIRE
Enlever_Filtre
[Attrib] = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Usf_Mao_Ds.Show_Repaint
End If
' MsgBox "CONSIGNES DE SAISIE :" & _
' " Cliquer au besoin sur le bouton (changer)'ordre LISTE' situé en D3 pour pouvoir, ensuite, CHOISIR (en cliquant sur la flèche en " & _
' "D4/E4) soit dans une liste NOM-Prénom soit dans une liste Prénom-NOM," & _
' " MAIS on peut aussi, pour les joueurs occasionnels, TAPER DIRECTEMENT un nom-prénom en D4. Dans les 2 cas, il faut " & _
' " toujours terminer par CLIQUER sur le bouton 'Ajouter' et, ensuite, saisir le sexe=F en col.E si 'Féminin' ou assimilé."
End Sub
Sub Tri_Joueurs_Reguliers()
Dim Plage As Range
Set Plage = Worksheets("Inscrip").Range([A_inscrire_si_1], [JOUEURS_REGULIERS])
If [Ordre_Liste] Like "P*" Then ' tri par Prénom
Plage.Sort _
Key1:=[JOUEURS_REGULIERS].Cells(4), Order1:=xlAscending, _
Key2:=[JOUEURS_REGULIERS].Cells(3), Order1:=xlAscending, _
Key3:=[JOUEURS_REGULIERS].Cells(5), Order1:=xlAscending, _
Header:=xlNo
Else
Plage.Sort _
Key1:=[JOUEURS_REGULIERS].Cells(3), Order1:=xlAscending, _
Key2:=[JOUEURS_REGULIERS].Cells(4), Order1:=xlAscending, _
Key3:=[JOUEURS_REGULIERS].Cells(5), Order1:=xlAscending, _
Header:=xlNo
End If
End Sub
Sub IMPRIM_LISTE_2col()
Application.Goto Reference:="LISTE_2cols"
Z = [LISTE_2cols].Offset(2).Columns(2).Resize(, 6).Address
ActiveSheet.PageSetup.PrintArea = Z
Print_Preview
[A_inscrire_si_1].Cells(1).Select
End Sub
Sub CADRER_INSCRIP()
Application.EnableEvents = False
Worksheets("INSCRIP").Select
REDUIRE 'les lignes inutilisées
Columns("C").Hidden = True
Columns("G").Hidden = True
Columns("A:R").Select: ActiveWindow.Zoom = True
[Joueurs_en_D5].Cells(1).Select
Application.EnableEvents = True
End Sub
Sub CADRER_NOTER()
Worksheets("NOTER 1 RESULTAT").Activate
[A1].Select
Application.Goto Reference:="CADRE_NOTER", Scroll:=True
ActiveWindow.Zoom = True
VERROU
[E9].Select
Usf_Mao_Ds.Show_Repaint
Suivi_Tour
End Sub
Sub Set_Score()
Worksheets("Noter 1 RESULTAT").Activate
For Each Sh In ActiveSheet.Shapes
If Sh.Name Like "Score_*" Then Sh.Delete
Next
H = 12
W = 12
Wmax = W * 14
X = ([Resultat].Left + [Resultat].MergeArea.Width) - Wmax
Y = [Resultat].Top - H
For I = 0 To 13
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, X, Y, W, H)
With shp
.Name = "Score_P_" & I
.Line.Weight = 0.25
With .OLEFormat.Object
.Interior.Color = 4697456
.Font.Color = vbWhite
.Font.Size = 6
.Font.Bold = True
End With
With .TextFrame2
.VerticalAnchor = msoAnchorMiddle
.TextRange.Characters.Text = IIf(I = 0, "G", Format(I, "+##;-##"))
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.MarginLeft = 0
.MarginTop = 0
.MarginRight = 0
.MarginBottom = 0
End With
.OnAction = "Click_Score"
End With
X = X + W
Next
X = ([Resultat].Left + [Resultat].MergeArea.Width) - Wmax
Y = [Resultat].Top + [Resultat].Height
For I = 14 To 1 Step -1
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, X, Y, W, H)
With shp
.Name = "Score_N_" & I
.Line.Weight = 0.25
With .OLEFormat.Object
.Interior.Color = vbRed
.Font.Color = vbWhite
.Font.Size = 6
.Font.Bold = True
End With
With .TextFrame2
.VerticalAnchor = msoAnchorMiddle
.TextRange.Characters.Text = IIf(I = 14, "P", Format(-I, "+##;-##"))
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.MarginLeft = 0
.MarginTop = 0
.MarginRight = 0
.MarginBottom = 0
End With
.OnAction = "Click_Score"
End With
X = X + W
Next
End Sub
Sub showactive()
Debug.Print Selection.Interior.Color
End Sub
Sub Set_Btn(X, Y, W, H, V)
Dim C As Long
Static Id: Id = IIf(Id > 999, 1, Id + 1)
With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, X, Y, W, H)
.Name = "Joueur_" & Id
.Line.Weight = 0.25
Select Case True
Case V Like "tour*": C = 2316088 ' vert foncé
Case Not IsNumeric(V): C = 5287936 ' Vert Pastel
Case V = Val(ActiveSheet.Cbx_Numéros): C = 8696052
Case Not V.DisplayFormat.Font.Strikethrough: C = 10855845 ' Gris
Case V.DisplayFormat.Interior.Color = vbRed: C = vbRed
Case Else: C = 3506772 ' vert foncé
End Select
.Fill.ForeColor.RGB = C
With .TextFrame2
.VerticalAnchor = msoAnchorMiddle
.TextRange.Characters.Text = V
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.TextRange.Font.Size = 10
.TextRange.Font.Bold = True
.MarginLeft = 0
.MarginTop = 0
.MarginRight = 0
.MarginBottom = 0
End With
.OnAction = "Click_Result"
End With
X = X + W
End Sub
Public Function IsRegistered() As Boolean
IsRegistered = [Supprimer].Visible
End Function
Public Function IsWin() As Boolean
Select Case True
Case [Resultat] = "G": IsWin = True
Case [Resultat] > 0: IsWin = True
End Select
End Function
Sub Suivi_Tour()
Dim Nrows As Long, N As Long, NP As Long
If [Tirage_Done] = "OK" Then
Application.EnableEvents = False
Application.ScreenUpdating = False
Set Rt = Worksheets("Tirages").Range("Tour_" & [Tour])
With Rt
.Parent.Activate
.EntireRow.Hidden = False
.EntireColumn.Hidden = False
NP = WorksheetFunction.CountIf(.Columns(1), ">0") ' Nombre de Parties en tout pour le tour
N = 0
Nrows = 3
For I = 2 To .Rows.Count
If .Cells(I, 1).Value > 0 Then
If .Cells(I, 1).DisplayFormat.Font.Strikethrough Then N = N + 1
Nrows = Nrows + 1
End If
If WorksheetFunction.CountA(.Rows(I)) = 0 Then Exit For
Next
End With
With Worksheets("Noter 1 RESULTAT")
.Activate
DEVERROU
On Error Resume Next
For Each Ctl In .Shapes
If Ctl.Name Like "*Joueur*" Then Ctl.Delete
Next
On Error GoTo Error_Trap
Dim BL, BT, BH, BW, R
BT = .[J3].Top
BH = 15
BW = 15
Id = 1
For R = 1 To Nrows
BL = .[J3].Left
Select Case True
Case R = 1 ' Titre
Set_Btn BL, BT, (BW * 6) + 2, BH, Rt.Cells(1, 1)
BT = BT + 2
Case R = 2 ' Blanc
If Rt.Cells(R, 3) <> "" Then
Set_Btn BL, BT, BW * 2, BH, Rt.Cells(R, 1)
Set_Btn BL, BT, BW, BH, Rt.Cells(R, 3)
Else
BT = BT - BH
End If
Case R = 3 ' Tête à tête
If Rt.Cells(R, 1) <> "" Then
Set_Btn BL, BT, BW * 2, BH, "TaT :"
Set_Btn BL, BT, BW, BH, Rt.Cells(R, 1)
Set_Btn BL + 2, BT, BW, BH, Rt.Cells(R, 4)
Else
BT = BT - BH
End If
Case R = 4 ' Doublette sup
If Rt.Cells(R, 1) <> "" Then
BL = BL + BW
Set_Btn BL, BT, BW, BH, Rt.Cells(R, 1)
Set_Btn BL, BT, BW, BH, Rt.Cells(R, 2)
BL = BL + 2
Set_Btn BL, BT, BW, BH, Rt.Cells(R, 4)
Set_Btn BL, BT, BW, BH, Rt.Cells(R, 5)
Else
BT = BT - BH
End If
BT = BT + 2
Case Worksheets("Tirages").[AM2] Like "*tête*"
BL = .[J3].Left + BW * 2
Set_Btn BL, BT, BW, BH, Rt.Cells(R, 1)
Set_Btn BL + 2, BT, BW, BH, Rt.Cells(R, 4)
Case Else
For C = 1 To 6
If Rt.Cells(R, C) <> "" Then
Set_Btn BL, BT, BW, BH, Rt.Cells(R, C)
Else
BL = BL + BW
End If
If C = 3 Then BL = BL + 2
Next
End Select
BT = BT + BH
Next
.[J2] = "Parties restantes : " & NP - N
If N = NP Then
Application.EnableEvents = True
If [Tour] < 4 Then
If MsgBox("Le tour " & [Tour] & " est terminé" & vbLf & vbLf & _
"Oui = passer au tour suivant" & vbLf & _
"Non = rester sur le tour", vbQuestion + vbYesNo) = vbYes _
Then [Tour] = [Tour] + 1
Else
If MsgBox("Le concours est terminé" & vbLf & _
"Voulez-vous procéder au paiement ?", vbInformation + vbYesNo) = vbYes Then _
Worksheets("Inscrip").Activate
End If
End If
End With
Application.EnableEvents = True
'[N_joueur].Activate
End If
Exit Sub
Error_Trap:
MsgBox Err.Number & vbLf & Err.Description
Resume Next
End Sub
Sub Click_Score()
V = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Caption
' If IsNumeric(V) Then [Resultat] = V
[Resultat] = V
End Sub
Sub Click_Result()
V = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Caption
If IsNumeric(V) Then
ActiveSheet.Cbx_Numéros = Val(V)
End If
[Tour].Activate
End Sub
Sub REDUIRE() 'les lignes inutilisées ou MONTRER les lignes utilisées >=30
Dim Lig As Integer
If [NBJR] < [Joueurs_en_D5].Rows.Count Then
Lig = Application.Max(28, [Joueurs_en_D5].Rows([Joueurs_en_D5].Rows.Count).End(xlUp).Row + 1)
With Worksheets("INSCRIP").Rows(Lig & ":" & "135")
If .RowHeight > 0 Then .RowHeight = 0
End With
VERROU
End If
End Sub
Sub PAIEMENTS()
Dim Largeur 'actuelle
Cells(2, 19) = IIf(Cells(2, 19) = 0, 5.29, 0)
Range("M:O").ColumnWidth = Cells(2, 19)
CADRER_INSCRIP
End Sub
Sub REPORT_DES_NOMS_AVEC_1()
Dim J As Integer
Worksheets("Inscrip").Activate
Enlever_Filtre
Application.EnableEvents = False
[Joueurs_en_D5].RowHeight = 28.5
[Joueurs_en_D5].Offset(, -1).Resize(, 1).FormulaR1C1 = "=IF(RC[-1]="""",3,IF(RC[2]=""F"",0,IF(RC[2]=""Z"",2,1))+RAND())"
[Joueurs_en_D5].Offset(, -2).Resize(, 1).FormulaR1C1 = "=IF(RC4="""","""",ROW()-ROW(R4C4))"
' On supprime toutes les lignes de joueurs_en_d5 qui n'ont pas de commentaires
For Each Cell In [Joueurs_en_D5]
If Cell.Comment Is Nothing And Cell <> vbNullString Then
Cell.Resize(, 2).ClearContents
End If
Next
N = Application.WorksheetFunction.CountA([Joueurs_en_D5].Columns(1)) _
+ Application.WorksheetFunction.CountA([Joueurs_liste].Columns(1))
If N > [MAX_JR] Then
MsgBox "Trop de joueurs" & vbLf & _
N & " Inscrits" & vbLf & _
"pour " & [MAX_JR] & " autorisés", vbCritical + vbOKOnly
Else
Nl = 0
'Debug.Print Application.WorksheetFunction.CountA([Joueurs_liste].Columns(1))
' on démarre la recherche à partir de la derniere cellule de la plage
F_Address = ""
Set R = [Joueurs_liste].Columns(1).Cells([Joueurs_liste].Rows.Count)
Set R = [Joueurs_liste].Columns(1).Find(Coché, R, xlValues, xlWhole, xlByColumns, xlPrevious)
Do While Not R Is Nothing
If F_Address = "" Then F_Address = R.Address
Nl = Nl + 1
' If Nl = 54 Then Stop
' Debug.Print Nl, " On cherche " & R.Offset(0, 2);
Set s = [Joueurs_en_D5].Find(R.Offset(0, 2))
If s Is Nothing Then
J = ([Joueurs_en_D5].Find(vbNullString, Range("D135")).Row - [Joueurs_en_D5].Row) + 1
[Joueurs_en_D5].Cells(J) = StrConv(R.Offset(0, 2), vbProperCase)
[Joueurs_en_D5].Cells(J).Offset(0, 1) = R.Offset(0, 3)
Else
Debug.Print " Not found"
End If
'R.Activate
Set R = [Joueurs_liste].Columns(1).Find(Coché, R, xlValues, xlWhole, xlByColumns, xlPrevious)
If R.Address = F_Address Then Set R = Nothing
Loop
End If
[TRI_noms].Sort _
Key1:=Range("E5"), Order1:=xlAscending, _
Key2:=Range("D5"), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Usf_Mao_Ds.Show_Repaint
Application.EnableEvents = True
Application.Goto [A1], True
CADRER_INSCRIP
End Sub
Sub ShowTip(ByVal Caption As String, B As Object, ByVal X As Single, ByVal Y As Single)
'On Error Resume Next
Dim TT As TextBox
Set TT = ActiveSheet.Shapes("TipText").OLEFormat.Object
With TT
Select Case True
Case Not B.Enabled: .Visible = False
Case (X > 2 And X < B.Width - 4) And (Y > 2 And Y < B.Height - 4)
If .Visible = False Then
.Caption = Caption
.Interior.Color = 13434879
.Left = B.Left + 1
.Top = B.Top - .Height - 1
.AutoSize = True
.Visible = True
End If
Case Else
.Visible = False
End Select
End With
DoEvents
End Sub
Sub IMPRIMER_LISTE_joueurs() 'LISTE forme ALPHA + forme NUMERIQUE
Dim L As Range
Sheets("Inscrip").Activate
If Not [Attrib] Then
MsgBox "L'attribution des N° n'ayant pas été faite," & vbLf _
& "Une liste simple des Joueurs Inscrits va être éditée", _
vbCritical, "Important"
IMPRIMER_LISTE_joueurs_Seuls
Else
Set L = [Joueurs_en_D5].Columns(1).Find("*", SearchDirection:=xlPrevious)
REDUIRE ' hauteur =0 si ligne vide
With ActiveSheet.PageSetup '=standard DS
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Zoom = False
.LeftMargin = Application.InchesToPoints(0.196850393700787)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.196850393700787)
.FitToPagesWide = 1
.PrintArea = "$AC$3:$AL$" & L.Row
End With
Print_Preview
End If
Range("A1").Select
End Sub
Sub IMPRIMER_LISTE_joueurs_Seuls() 'LISTE forme ALPHA
Dim L As Range, Simple As Boolean
With Sheets("Inscrip")
Set L = [Joueurs_en_D5].Find("*", SearchDirection:=xlPrevious)
Set Plage = [Joueurs_en_D5].Rows("1:" & L.Row - [Joueurs_en_D5].Row + 1)
N1 = WorksheetFunction.RoundUp(Plage.Rows.Count / 2, 0)
Worksheets("Temp").Visible = True
Worksheets("Temp").Select
Cells.Delete
Cells.Font.Size = 14
Cells.Font.Name = "Calibri"
[A1] = "Nom Prénom"
With [A2].Resize(N1)
.Value = Plage.Resize(N1).Value
With .Parent.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes)
.Name = "Tableau1"
.TableStyle = "TableStyleMedium6"
End With
.Columns.AutoFit
End With
N2 = Plage.Rows.Count - N1
[C1] = "Nom Prénom"
With [C2].Resize(N2)
.Value = Plage.Offset(N1).Resize(N2).Value
With .Parent.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes)
.Name = "Tableau2"
.TableStyle = "TableStyleMedium6"
End With
.Columns.AutoFit
End With
Rows(1).RowHeight = Rows(1).RowHeight * 2
Columns("B").ColumnWidth = 5
H = Application.Max(Columns("A").ColumnWidth, Columns("C").ColumnWidth)
Columns("A").ColumnWidth = H
Columns("C").ColumnWidth = H
With ActiveSheet.PageSetup
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Zoom = False
.LeftMargin = Application.InchesToPoints(0.196850393700787)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.196850393700787)
.LeftFooter = "&""Calibri,Gras italique""&12 " & Plage.Rows.Count & " joueurs"
.PrintArea = [A:C].Resize(WorksheetFunction.Max(N1, 12) + 1).Address
End With
Print_Preview
Worksheets("Temp").Visible = False
End With
End Sub