Microsoft 365 Inscrire automatiquement la date du jour et bloquer les cellules

sebastien176

XLDnaute Junior
Bonjour à tous,

Dans le fichier ci-joint, j'aimerais pourvoir mettre :
1 - la date du jour dans la colonne J quand je renseigne la colonne H
2 - Pareil pour la colonne N quand je renseigne la colonne L

J'ai déjà ce code sur la feuille "cariste" mais n'arrive pas à trouver le moyen de faire la même chose pour les colonne L et N:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 8 Then Exit Sub
If Target.Row = 1 Then Exit Sub
Target.Offset(0, 2) = Date
Target.Offset(0, 2).Value = Target.Offset(0, 2).Value
Application.ScreenUpdating = False
ActiveSheet.Unprotect
If Not Intersect(Target, Columns("h")) Is Nothing Then
On Error Resume Next
For w = 1 To Range("h" & Rows.Count).End(xlUp).Row
If Range("h" & w) = "" Then
Range("h" & w).Locked = False
Range("j" & w).Locked = False
Else
Range("h" & w).Locked = True
Range("j" & w).Locked = True
End If
Next
End If
ActiveSheet.Protect
End Sub

Je vous remercie par avance de votre aide

Seb
 

Pièces jointes

  • Suivi avec dates.xlsm
    67.9 KB · Affichages: 8
Solution
Bonjour sebastien176, le forum,

Le plus simple est de compléter la macro comme ceci :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Union([H:H], [L:L]), UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r
    If IsNumeric(CStr(r)) Or CStr(r) <> "" And r.Interior.Color = vbRed Then r(1, 3) = Date
Next
End Sub
A+

job75

XLDnaute Barbatruc
Bonjour sebastien176,
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Union([H:H], [L:L]), UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r
    If IsNumeric(CStr(r)) Then r(1, 3) = Date
Next
End Sub
Je ne m'occupe pas de la protection éventuelle.

A+
 

sebastien176

XLDnaute Junior
Bonjour sebastien176,
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Union([H:H], [L:L]), UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r
    If IsNumeric(CStr(r)) Then r(1, 3) = Date
Next
End Sub
Je ne m'occupe pas de la protection éventuelle.

A+
Bonjour Job75,

Je te remercie pour ton retour sur ma demande

je viens de vérifier ton code

Il marche bien mais quelques éléments me manque :

- Sur la dernière ligne de chaque mois (ligne rouge) je dois remplir en texte par la liste déroulante des colonnes H et L . Du coup il n'y à pas de report de date dans les colonnes J et N pour ces lignes.

As-tu une solutions à ces questions ?

merci d'avance

Bonne journée

Seb
 

job75

XLDnaute Barbatruc
Bonjour sebastien176, le forum,

Le plus simple est de compléter la macro comme ceci :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Union([H:H], [L:L]), UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r
    If IsNumeric(CStr(r)) Or CStr(r) <> "" And r.Interior.Color = vbRed Then r(1, 3) = Date
Next
End Sub
A+
 

sebastien176

XLDnaute Junior
Bonjour sebastien176, le forum,

Le plus simple est de compléter la macro comme ceci :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Union([H:H], [L:L]), UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r
    If IsNumeric(CStr(r)) Or CStr(r) <> "" And r.Interior.Color = vbRed Then r(1, 3) = Date
Next
End Sub
A+
Super,

Merci encore pour ton aide Job75
Cela marche très bien

Bonne journée

Seb
 

Statistiques des forums

Discussions
313 296
Messages
2 096 922
Membres
106 787
dernier inscrit
Rachid ALIOU