Macro : Date fixe si condition

VB:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 4 Then Target.Offset(0, -2) = Date
    Dim FeBase As Worksheet
    Dim Fe As Worksheet
    Dim Ligne As Long

    If Target.Count > 1 Then Exit Sub 'suite à une sélection multiple et suppression par exemple
    If Target.Column <> 26 Then Exit Sub 'colonne AA
    If Target.Row < 6 Then Exit Sub 'pas les lignes d'entêtes

    'si la valeur est 1, on lance le transfert
    If Target.Value = 1 Then

        Set FeBase = Worksheets("PENALITE")

        On Error Resume Next
        Set Fe = Worksheets(Cells(Target.Row, 2).Value)

        If Err.Number <> 0 Then
   
            'gèle l 'affichage
            Application.ScreenUpdating = False
   
            Set Fe = Worksheets.Add(, Sheets(Sheets.Count))
            Fe.Name = Cells(Target.Row, 2).Value
            Err.Clear
   
            're-sélectionne la feuille car la création mets le focus sur la nouvelle feuille
            FeBase.Select
   
            'rafraîchi
            Application.ScreenUpdating = True

         End If

        'transfert
        With Fe: Ligne = .Cells(.Rows.Count, 2).End(xlUp).Row: End With

        If Ligne = 1 And Fe.Cells(1, 2).Value = "" Then
        'Collage celulle A1
            Fe.Range(Fe.Cells(1, 1), Fe.Cells(2, 24)).Value = FeBase.Range(FeBase.Cells(5, 2), FeBase.Cells(5, 25)).Value
        End If
   'le Targetrow,25 change rien

        Fe.Range(Fe.Cells(Ligne + 1, 1), Fe.Cells(Ligne + 1, 24)).Value = FeBase.Range(FeBase.Cells(Target.Row, 2), FeBase.Cells(Target.Row, 25)).Value


    End If

End Sub

Cliquez pour agrandir...