Gérer un calendrier

Sub Recap()
' Macro recap qui permet de remplir le fichier recap fermeture pour ouverture
Application.ScreenUpdating = False
Dim TabRecap() As Variant
Set listeTrajets = CreateObject("Scripting.Dictionary")

Dim nb As Integer, h As Integer, w As Integer, pole As String, datecir As String

Set FL1 = Sheets("Saisie des fermetures")
Set FL2 = Worksheets("Recap Fermeture pour Ouverture")

ann2 = FL1.Range("C1")
ann1 = ann2 - 1

With FL2 'on efface la feuille "Recap" sauf les colonnes L,W,AB,AG,AL,AQ
    TabRecap = .UsedRange.Offset(8, 0).Value
    For i = LBound(TabRecap, 1) To UBound(TabRecap, 1)
        For j = LBound(TabRecap, 2) To UBound(TabRecap, 2)
            If j <> 12 And j <> 23 And j <> 28 And j <> 33 And j <> 38 And j <> 43 Then
                TabRecap(i, j) = ""
            End If
        Next j
    Next i
    .Range("A9").Resize(UBound(TabRecap, 1), UBound(TabRecap, 2)) = TabRecap
End With
'******************************
With FL1
    LastCol = .Cells(6, .Columns.Count).End(xlToLeft).MergeArea.Offset(0, 1).Column - 1
    LastLine = .UsedRange.Rows.Count
    TabloFL1 = .Range("B8:AG" & LastLine).Value
    On Error Resume Next 'permet de bypasser les erreurs qui apparaissent lorsqu'on va vouloir créer un trajet déjà existant
    For i = LBound(TabloFL1, 1) To UBound(TabloFL1, 1)
        'sur la colonne B, on récupère les numéros de trajet UNIQUE avec leur position dans le tableau "TabloFL1"
        listeTrajets.Add TabloFL1(i, 1), i 'créer une liste sans doublon des trajets de la colonne B = 1ere colonne du tablo
    Next i
End With
'******************************

'traitement principal
With FL1
    For Each Trajet In listeTrajets.keys 'sur chaque Trajet de la colonne B
        NoLig = listeTrajets(Trajet) 'on récupère la position dans la table
        If TabloFL1(NoLig, 30) <> "" Then 's'il y a une date de fermeture
            k = WorksheetFunction.CountA(.Range("AH" & NoLig + 7).Resize(1, LastCol - 33)) 'compte le nombre de jours dans le calendrier à traiter
            ReDim ListeJours(1 To k) 'redimensionne le tableau qui contient les k DateCir à traiter
            i = 1
            'on remplit le tableau avec les DateCir
            For Each ele In .Range("AH" & NoLig + 7).Resize(1, LastCol - 33).SpecialCells(xlTextValues)
                ListeJours(i) = .Cells(6, ele.Column)
                i = i + 1
            Next ele
            inserer2 'appel de la macro "Inserer2"
        End If
    Next Trajet
End With

With FL2
    FinFeuille = .Range("B" & .Rows.Count).End(xlUp).Row
    For nb = 9 To FinFeuille
        If .Range("S" & nb) <> "" Then .Range("Y" & nb) = .Range("S" & nb)
        If .Range("AD" & nb) <> "" Then
            .Range("S" & nb) = .Range("AD" & nb)
            .Range("Y" & nb) = .Range("AD" & nb)
        End If
    Next nb
End With

Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim aRow As Integer
If Target.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
With ActiveSheet
    Fin = .UsedRange.Rows.Count
    If Not Intersect(Target, Range("X8:X" & Fin)) Is Nothing Then
        .Range("Z" & Target.Row) = Date
    End If
    .Range("A" & Target.Row) = Date
End With
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim aRow As Integer
If Target.Cells.Count > 1 Or Target.Row < 8 Then Exit Sub
Application.EnableEvents = False
With ActiveSheet
    Fin = .UsedRange.Rows.Count
    If Not Intersect(Target, Range("X8:X" & Fin)) Is Nothing Then
        .Range("Z" & Target.Row) = Date
    End If
    .Range("A" & Target.Row) = Date
End With
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim aRow As Integer
If Target.Cells.Count > 1 Or Target.Row < 8 Or Target = "" Then Exit Sub
Application.EnableEvents = False
With ActiveSheet
    Fin = .UsedRange.Rows.Count
    If Not Intersect(Target, Range("X8:X" & Fin)) Is Nothing Then
        .Range("Z" & Target.Row) = Date
    End If
    .Range("A" & Target.Row) = Date
End With
Application.EnableEvents = True
End Sub

Sub dupliquermassive()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim lignes As Integer
Dim debut As Integer


If ActiveCell.Column <> 2 Then Exit Sub 'si on clique ailleurs qu'en colonne B, on sort

debut = ActiveCell 'InputBox("N° DE DEBUT ")
fin = InputBox("Demande de fermeture massive : Du trajet n° " & debut & Chr(10) & "Aux trajets n° ")
If fin = "" Then
    MsgBox ("saisie vide, saissisez un n°")
    Exit Sub
Else
    Listetrajet = Split(fin, ";")
End If

Rep = MsgBox("Confirmation de la fermeture massive des trajets n° " & debut & " jusqu'au n° " & fin, vbYesNo)
If Rep = 7 Then Exit Sub
j = UBound(Listetrajet)
For i = ActiveCell.Row To ActiveCell.Row + UBound(Listetrajet, 1)
   
    With ActiveCell
        .EntireRow.Offset(1, 0).Insert Shift:=xlDown
        .EntireRow.Copy Destination:=.EntireRow.Offset(1, 0)
        .Offset(1, 0) = CInt(Listetrajet(j))
        j = j - 1
       
    End With
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sub dupliquermassive()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim lignes As Integer
Dim debut As Integer


If ActiveCell.Column <> 2 Then Exit Sub 'si on clique ailleurs qu'en colonne B, on sort

debut = ActiveCell 'InputBox("N° DE DEBUT ")
fin = InputBox("Demande de fermeture massive : Du trajet n° " & debut & Chr(10) & "Aux trajets n° ")
If fin = "" Then
    MsgBox ("saisie vide, saissisez un n°")
    Exit Sub
Else
    For i = 1 To Len(fin)
        If Not ((Mid(fin, i, 1) >= 0) And (Mid(fin, i, 1) <= 9) Or (Mid(fin, i, 1) = ";")) Then
            MsgBox ("saisie incorrecte, ce caractère n'est pas autorisé: " & Chr(10) & Mid(fin, i, 1))
            Exit Sub
        End If
    Next i
End If
    Listetrajet = Split(fin, ";")


Rep = MsgBox("Confirmation de la fermeture massive des trajets n° " & debut & " jusqu'au n° " & fin, vbYesNo)
If Rep = 7 Then Exit Sub
j = UBound(Listetrajet)
For i = ActiveCell.Row To ActiveCell.Row + UBound(Listetrajet, 1)
   
    With ActiveCell
        .EntireRow.Offset(1, 0).Insert Shift:=xlDown
        .EntireRow.Copy Destination:=.EntireRow.Offset(1, 0)
        .Offset(1, 0) = CInt(Listetrajet(j))
        j = j - 1
       
    End With
Next i
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub