Simulation roulement

 Workbooks.Open Filename:="C:\Emplacement du dossier\SERVICES PERIODE 1 v1.xlsm"

    Sheets("Roulement conducteur 2").Select
    Sheets("Roulement conducteur 1").Select

 If Sem <> 1 Then Onglet = Left(Jour, 3) & " (" & Sem & ")" Else: Onglet = Left(Jour, 3)

 If Sem <> 1 Then Onglet = Left(Jour, 3) & "  (" & Sem & ")" Else: Onglet = Left(Jour, 3)

Sub Degrisage()
    Application.ScreenUpdating = False
    Windows("SERVICES PERIODE 1 v1.xlsm").Activate
    Sheets("lun").Select
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets(Array("lun", "lun (2)", "lun (3)", "lun (4)", "lun (5)", "lun (6)", "lun (7)", _
        "lun (8)", "mar ", "mar (2)", "mar (3)", "mar (4)", "mar (5)", "mar (6)", "mar (7)", _
        "mar (8)", "mer ", "mer (2)", "mer (3)", "mer (4)", "mer (5)", "mer (6)", "mer (7)", _
        "mer (8)", "jeu")).Select
    Sheets(Array("jeu (2)", "jeu (3)", "jeu (4)", "jeu (5)", "jeu (6)", "jeu (7)", _
        "jeu (8)", "ven", "ven (2)", "ven (3)", "ven (4)", "ven (5)", "ven (6)", "ven (7)", _
        "ven (8)", "sam", "sam (2)", "sam (3)", "sam (4)", "sam (5)", "sam (6)", "sam (7)", _
        "sam (8)", "dim", "dim (2)")).Select Replace:=False
    Sheets(Array("dim (3)", "dim (4)", "dim (5)", "dim (6)", "dim (7)", "dim (8)")).Select Replace:=False
    Range("A2:S200").Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets(1).Select
    Windows("SIMULATEUR ROULEMENT V1.xlsm").Activate
End Sub

Workbooks.Open Filename:="C:\Users\jenetniz\Desktop\Pimous\SERVICES PERIODE 1 v1.xlsm"

Sub Grisage()
    Application.ScreenUpdating = False
    FeuilleActive = ActiveSheet.Name
    Windows("SERVICES PERIODE 1 v1.xlsm").Activate
    If Sem <> 1 Then Onglet = Left(Jour, 3) & " (" & Sem & ")" Else: Onglet = Left(Jour, 3)
    Sheets(Onglet).Select
    With Range("A2:S91").Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Set C = Columns("A").Find(Service, LookIn:=xlValues)
    If C Is Nothing Then
        MsgBox "Service introuvable dans le classeur ""SERVICES PERIODE"""
        Exit Sub
    End If
    C.Select
    NbLig = Selection.Rows.Count
    With Range(Cells(C.Row, "A"), Cells(C.Row + NbLig - 1, "S")).Interior
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893
    End With
    Windows("SIMULATEUR ROULEMENT V1.xlsm").Activate
    Sheets(FeuilleActive).Select
End Sub

Sub RetirerService()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    FeuilActive = ActiveSheet.Name
    Liste = Jour & " sem " & Sem
    Sheets("Services").Select
    Set l = Rows("1").Find(Liste, LookIn:=xlValues)
    If l Is Nothing Then Exit Sub
    l.Select
    Range("A2:A49").Copy
    Range(Cells(l.Row + 1, l.Column), Cells(49, l.Column)).Select
    ActiveSheet.Paste
    Set ListServ = Range(Cells(l.Row, l.Column), Cells(50, l.Column))
    Set C = ListServ.Find(Service, LookIn:=xlValues)
    If C Is Nothing Then Exit Sub
    C.ClearContents
    Range(Cells(1, l.Column), Cells(50, l.Column)).Select
    ActiveWorkbook.Worksheets("Services").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Services").Sort.SortFields.Add Key:=Range(Cells(2, l.Column), Cells(50, l.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Services").Sort
        .SetRange Range(Cells(1, l.Column), Cells(50, l.Column))
        .Header = xlYes
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets(FeuilActive).Select
    Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D10:J17")) Is Nothing Then
        Jour = Cells(9, Target.Column)
        Sem = Cells(Target.Row, "C")
        Service = Target
        ServiceEx = [A1]
        RetirerService
        'grisage dans le classeur "Services périodes"
        Grisage
        [A1] = Target
        [A1].Select
    End If
End Sub

Sub RetirerService()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    FeuilActive = ActiveSheet.Name
    Liste = Jour & " sem " & Sem
    Sheets("Services").Select
    Set l = Rows("1").Find(Liste, LookIn:=xlValues)
    If l Is Nothing Then Exit Sub
    l.Select
    
    Set ListServ = Range(Cells(l.Row, l.Column), Cells(50, l.Column))
    If ServiceEx <> "" Then
        Set C = ListServ.Find(ServiceEx, LookIn:=xlValues)
        If C Is Nothing Then Cells(49 + 1, l.Column) = ServiceEx
    End If
    
    Set C = ListServ.Find(Service, LookIn:=xlValues)
    C.ClearContents
    Range(Cells(1, l.Column), Cells(50, l.Column)).Select
    ActiveWorkbook.Worksheets("Services").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Services").Sort.SortFields.Add Key:=Range(Cells(2, l.Column), Cells(50, l.Column)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Services").Sort
        .SetRange Range(Cells(1, l.Column), Cells(50, l.Column))
        .Header = xlYes
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets(FeuilActive).Select
    Application.Calculation = xlCalculationAutomatic
End Sub