Adresse de la cellule active?
Résolu
Bonjour, je suis à mes début avec VBA pour excel. Voici ce que je veux faire: dès qu'il y a une modification d'une valeur dans le range(a15:p200) je veux inscrire sur la ligne où il y a eu modification dans la cellule Q(no de ligne) la date d'aujourd'hui. Dans la colonne R les cellules contiennent =aujourdhui(). et finalement dans la colonne S se trouve les formules suivantes = R(no de ligne)-Q(no de ligne). Le but ultime étant de faire une mise en forme conditionnelle sur les valeurs de la ligne a..p. l'idée étant de mettre en surbrillance jaune pendant 5 jours toutes les modifications faites.
Ça fait deux jours que je cherche et que j'essaie toutes sorte de solution et j'aurais besoin d'aide. Voici où j'en suis rendu:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("a15:p200")) Is Nothing Then
For Each Cel In Target
If Not Intersect(Cel, Range("a15:p15")) Is Nothing Then
' sauvegarder la position de la cellule modifiée
Range("a1").Value = ActiveCell.Address
Range("r15").Select
ActiveCell.FormulaR1C1 = "=today()"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' remettre la sélection sur la cellule modifiée.
ActiveCell.Address = Range("a1").Value
End If
Application.EnableEvents = True
End Sub
Ça fait deux jours que je cherche et que j'essaie toutes sorte de solution et j'aurais besoin d'aide. Voici où j'en suis rendu:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("a15:p200")) Is Nothing Then
For Each Cel In Target
If Not Intersect(Cel, Range("a15:p15")) Is Nothing Then
' sauvegarder la position de la cellule modifiée
Range("a1").Value = ActiveCell.Address
Range("r15").Select
ActiveCell.FormulaR1C1 = "=today()"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' remettre la sélection sur la cellule modifiée.
ActiveCell.Address = Range("a1").Value
End If
Application.EnableEvents = True
End Sub
2 réponses
-
J'ai été un peu trop vite, au lieu d'utiliser l'évènement Worksheet_Activate (dont on est pas sur qu'il se produise), il est préférable d'utiliser l'évènement Workbook_Open (qui se produit à chaque ouverture du classeur) :
Private Sub Workbook_Open()
'Effacer les lignes surlignées après 5 jours
'
Const p As Integer = 5 'période = 5 jour
Dim wsh As Worksheet
Dim Cel As Range
Application.EnableEvents = False
'Préciser le nom de la feuille concernée
Set wsh = Worksheets("Feuil1")
With wsh
For Each Cel In .Range("Q15:Q200").Cells
If Now - .Cells(Cel.Row, "Q").Value >= p Then
'Effacer la couleur
.Range("A" & Cel.Row & ":P" & Cel.Row).Interior.ColorIndex = xlColorIndexNone
End If
Next Cel
End With
Application.EnableEvents = True
End Sub
-
Bonjour,
Pour répondre aux questions précises de ton problème :Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("a15:p200")) Is Nothing Then
For Each Cel In Target.Cells
If Not Intersect(Cel, Range("a15:p200")) Is Nothing Then
'colonne Q : n° de ligne
Cells(Cel.Row, "Q").Formula = Cel.Row
'colonne R, formule : =AUJOURDHUI()
Cells(Cel.Row, "R").FormulaLocal = "=AUJOURDHUI()"
'colonne S, formule : = R(no de ligne)-Q(no de ligne)
Cells(Cel.Row, "S").FormulaLocal = "=R" & Cel.Row & " - Q" & Cel.Row
End If
Next Cel
End If
Application.EnableEvents = True
End Sub
Mais, pour mettre en surbrillance jaune pendant 5 jours toutes les modifications faites :Private Sub Worksheet_Activate()
'Effacer les lignes surlignées après 5 jours
'
Const p As Integer = 5 'période = 5 jour
Dim Cel As Range
Application.EnableEvents = False
For Each Cel In Range("Q15:Q200").Cells
If Now - Cells(Cel.Row, "Q").Value >= p Then
'Effacer la couleur
Range(Cells(Cel.Row, "A"), Cells(Cel.Row, "P")).Interior.ColorIndex = xlColorIndexNone
End If
Next Cel
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Surligner les lignes modifiées
Dim Cel As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("a15:p200")) Is Nothing Then
For Each Cel In Target.Cells
If Not Intersect(Cel, Range("a15:p200")) Is Nothing Then
'colonne Q : instant de la modification
Cells(Cel.Row, "Q").Formula = Now
'ligne surlignée e vert
Range(Cells(Cel.Row, "A"), Cells(Cel.Row, "P")).Interior.ColorIndex = 6
End If
Next Cel
End If
Columns("Q").AutoFit
Application.EnableEvents = True
End Sub
