XL 2016 VBA insérer automatiquement une valeur sous la cellule active

piga25 · 25 Septembre 2018

Bonjour,
Après pas mal de recherches, je bloque sur le code suivant.
Dans une feuille, lorsque je tape P ou X j'aimerai que sous cette cellule s'inscrive automatiquement la valeur (format heure) qui est située dans la même colonne mais dans une ligne bien définie.
Il y a uniquement la ligne 9 et celle qui correspond à FinNom +3 qui ont ces données.

lorsque je mets par exemple dans le code

VB:

Case "P"
        ActiveCell.Offset(0, 0) = "10:30"

cela fonctionne
mais quand je fait référence à la cellule contenant l'heure située plus haut cela ne fonctionne plus.

VB:

Sub Worksheet_Change(ByVal Target As Range)
Dim FinNom As Long
Dim x, y As Date
FinNom = ActiveSheet.Range("A7").End(xlDown).Row
  x = Cells(9, ActiveCell.Column).Value
  y = Cells(FinNom + 3, ActiveCell.Column).Value

If Target.Column < 25 Then Exit Sub 'si avant colonne 25 on sort de la procédure

If Target.Row < FinNom Then ' si saisie avant la ligne située avant finnom
    Select Case Target.Value
    Case ""
        ActiveCell.Offset(1, 0) = ""
    Case "P"
        ActiveCell.Offset(0, 0) = x 'Cells(9, 0).Value
    Case "X"
        ActiveCell.Offset(0, 0) = x 'Cells(9, 0).Value
    Case "A"
        ActiveCell.Offset(0, 0) = ""
    End Select
If Target.Row > FinNom Then ' si saisie avant la ligne située après finnom
    Select Case Target.Value
    Case ""
        ActiveCell.Offset(1, 0) = ""
    Case "P"
        ActiveCell.Offset(0, 0) = y 'Cells(FinNom + 3, 0).Value
    Case "X"
        ActiveCell.Offset(0, 0) = y 'Cells(FinNom + 3, 0).Value
    Case "A"
        ActiveCell.Offset(0, 0) = ""
    End Select
End If
End If
End Sub

job75 · 26 Septembre 2018

Bonjour piga25, Robert, le forum,

Pour le cas où l'on ferait des entrées multiples il vaut mieux faire une boucle :

Code:

Sub Worksheet_Change(ByVal R As Range)
If R.Column < 25 Or Cells(R.Row, 2) = "" Or Cells(R.Row, 2) = "Prévisionnel" Then Exit Sub
Set R = Intersect(R, Range("A1", UsedRange)) 'limite la zone étudiée
If R Is Nothing Then Exit Sub
Dim c As Range
For Each R In R 'si entrées multiples
    If UCase(R) <> R Then R = UCase(R) 'majuscules
    Set c = Range("B1", Cells(R.Row, 2)).Find("Prévisionnel", , xlValues, , , xlPrevious)
    If Not c Is Nothing Then
        If R = "P" Or R = "X" Then R(2) = Cells(c(2).Row, R.Column) _
        Else If R = "A" Then R(2) = ""
    End If
Next
End Sub

Fichier joint.

Bonne journée.

piga25 · 26 Septembre 2018

Bonjour Job 75, le forum
Merci pour ce code. Qu'est ce que j'aimerai pouvoir coder comme cela, simple et surtout concis.
J'ai pris le temps de comprendre.
J'aime surtout ces lignes :
Set R = Intersect(R, Range("A1", UsedRange)) 'limite la zone étudiée
et
If UCase(R) <> R Then R = UCase(R) 'majuscules

Dans mon essai de code, cela me posait problème. J'avais des bugs, mais là avec votre code sur le fichier complet tout semble fonctionner parfaitement.

Autre avantage, peut importe la manière de valider, l'info se met toujours sur la cellule.

Un grand merci

XL 2016 VBA insérer automatiquement une valeur sous la cellule active

piga25

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

piga25

XLDnaute Barbatruc

Discussions similaires