XL 2016 Aide pour maj auto de la date + selection multiple dans une liste déroulante

petitbuzuc

petitbuzuc

XLDnaute Nouveau
Bonjour à tous

j'ai un fichier excel à faire : je vous le mets en PJ.

dans la colonne J, j'ai une macro qui me permet de sélectionner plusieurs items dans une liste déroulante

If Target.Column = 10 And Target.Address <> "$J$1" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & RetourChariot & Newvalue
Rows(ActiveCell.Row).EntireRow.AutoFit
Else:
Target.Value = Oldvalue
End If
End If
End If
End If


mais je veux aussi rajouter un code vba pour que lorsque quelque chose est modifié sur la ligne (sauf colonne A), alors on met la date et l'heure de la modification en colonne A

Dim ligne As Integer
For ligne = 2 To 10000
Set Plage = Range("B" & ligne & ":Z" & ligne)
If Application.Intersect(Target, Plage) Is Nothing Then
'Hors cible on ne fait rien.
Else
Cells(ligne, "A").Value = Date & " " & Time
Cells(ligne, "A").NumberFormat = "dd/mm/yyyy"
End If
Next
Range("A:A").EntireColumn.AutoFit



Chaque bout de code fonctionne, mais quand je mets les 2 morceaux de code, alors ça ne fonctionne plus.
:-(
je pense que le pb vient que la "target" revient en colonne A une fois que j'ai modifié la colonne J et que du coup, ça n'arrive pas à permettre de selectionner plusieurs items de ma liste déroulante en J.


voila voila ...

si vous avez du code plus efficace, je suis preneuse !!!

Merci d'avance pour votre aide !
Anne
 

Pièces jointes

  • Essai.xlsm
    39 KB · Affichages: 10
Dernière édition:
Trier par date Trier par votes
A

Annach

XLDnaute Nouveau
Bonjour Petitbuzuc,

Le code est correct mais il faut séparer les 2 actions et ne faire appel à la fonction sur J que si modification sur J (création de la "function colonne_J" au même endroit que le 1er code) .

VB: 
Option Explicit 'oblige à la déclaration de toutes les variables
  
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligne As Integer
Dim Plage As Range

If Target.Column = 10 And Target.Address <> "$J$1" Then   'si la colonne J est modifiée, alors on fait appel à la fonction 
    Call colonne_j(Target)
End If

For ligne = 2 To 10000
    Set Plage = Range("B" & ligne & ":Z" & ligne)
    If Application.Intersect(Target, Plage) Is Nothing Then
        'Hors cible on ne fait rien.
    Else
        Cells(ligne, "A").Value = Date & " " & Time
        Cells(ligne, "A").NumberFormat = "dd/mm/yyyy"
    End If
Next
Range("A:A").EntireColumn.AutoFit
Exitsub:
Application.EnableEvents = True
End Sub

'fonction colonne J
Function colonne_j(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Dim RetourChariot As String
RetourChariot = Chr(10)

Application.EnableEvents = True
On Error GoTo Exitsub

''multiple choix possible "services impactés" en colonne J

  If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
  Else: If Target.Value = "" Then GoTo Exitsub Else
    Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
      If Oldvalue = "" Then
        Target.Value = Newvalue
      Else
        If InStr(1, Oldvalue, Newvalue) = 0 Then
            Target.Value = Oldvalue & ", " & RetourChariot & Newvalue
            Rows(ActiveCell.Row).EntireRow.AutoFit
      Else:
        Target.Value = Oldvalue
      End If
    End If
  End If

Exitsub:
Application.EnableEvents = True

End Function

Cordialement
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
Salut à tous,
dans ce code, on peut étendre à toutes les colonnes avec validation du tableau,
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel         As Range
Dim I           As Integer
Dim Oldvalue    As String
Dim Newvalue    As String

For Each Cel In Target
    If Not Intersect(Cel, [tableau_suivi_veille[#Data]]) Is Nothing Then
       ' Index de la ligne dans le tableau
        I = Cel.Row - [tableau_suivi_veille[#Headers]].Row
        Select Case True
       ' la ligne ci-dessous est à supprimer ou commenter pour traiter toutes les colonnes du tableau
        Case Intersect(Cel, [tableau_suivi_veille[Section]]) Is Nothing
        Case Cel = ""
        Case Intersect(Cel, Me.Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing
        Case Else
                Application.EnableEvents = False
                    Newvalue = Cel.Value
                        Application.Undo
                    Oldvalue = Cel.Value
                    Select Case True
                    Case Oldvalue = "": Cel = Newvalue
                    Case Not InStr(1, Oldvalue & ",", Newvalue & ",") > 0 ' ne pas trouver 1 dans 10
                        Cel = Oldvalue & ", " & vbLf & Newvalue
                        Cel.EntireRow.AutoFit
                    End Select
                Application.EnableEvents = True
        End Select
        With [tableau_suivi_veille[Date mise à jour]].Rows(I)
            Application.EnableEvents = False
                .Value = Now
                .Columns.AutoFit
            Application.EnableEvents = True
        End With

    End If
Next

End Sub
 
Vote positif 0 Vote négatif
petitbuzuc

petitbuzuc

XLDnaute Nouveau
fanch55 à dit:
Salut à tous,
dans ce code, on peut étendre à toutes les colonnes avec validation du tableau,
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel         As Range
Dim I           As Integer
Dim Oldvalue    As String
Dim Newvalue    As String

For Each Cel In Target
    If Not Intersect(Cel, [tableau_suivi_veille[#Data]]) Is Nothing Then
       ' Index de la ligne dans le tableau
        I = Cel.Row - [tableau_suivi_veille[#Headers]].Row
        Select Case True
       ' la ligne ci-dessous est à supprimer ou commenter pour traiter toutes les colonnes du tableau
        Case Intersect(Cel, [tableau_suivi_veille[Section]]) Is Nothing
        Case Cel = ""
        Case Intersect(Cel, Me.Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing
        Case Else
                Application.EnableEvents = False
                    Newvalue = Cel.Value
                        Application.Undo
                    Oldvalue = Cel.Value
                    Select Case True
                    Case Oldvalue = "": Cel = Newvalue
                    Case Not InStr(1, Oldvalue & ",", Newvalue & ",") > 0 ' ne pas trouver 1 dans 10
                        Cel = Oldvalue & ", " & vbLf & Newvalue
                        Cel.EntireRow.AutoFit
                    End Select
                Application.EnableEvents = True
        End Select
        With [tableau_suivi_veille[Date mise à jour]].Rows(I)
            Application.EnableEvents = False
                .Value = Now
                .Columns.AutoFit
            Application.EnableEvents = True
        End With

    End If
Next

End Sub
Cliquez pour agrandir...
Ca marche super, un grand merci ! si tu as encore 2 min à me consacrer : peux tu juste m'éclairer sur un point : comment fais tu pour qu'on puisse sélectionner plusieurs valeurs en colonne J dans la liste déroulante ? car je ne vois pas dans le code de référence à la colonne J ! 🤔 c'est juste pour monter en compétence :)
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
Salut,
On ne fait pas référence à la colonne "J" mais à la colonne portant le nom Section du Tableau.
De ce fait, tu peux si tu le désires, déplacer celle-ci dans le tableau, le code fonctionnera toujours .
Enrichi (BBcode): 
       ' la ligne ci-dessous est à supprimer ou commenter pour traiter toutes les colonnes du tableau
        Case Intersect(Cel, [tableau_suivi_veille[Section]]) Is Nothing 
               '--> si la cellule n'appartient pas à la colonne Section, on sort du select
        Case Cel = "" 
                '--> la cellule doit être renseignée
        Case Intersect(Cel, Me.Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing 
                '--> la suite ne se fera que si la cellule a une liste de validation
C'est dans la partie "Case Else" qu'on "cumule" les valeurs :
On sauvegarde la valeur entrée dans la variable NewValue.
On annule la saisie (undo) pour récupérer l'ancienne valeur .
Si on ne trouve pas déjà NewValue dans l'ancienne valeur,
on l'ajoute à l'ancienne valeur et on ajuste la hauteur de ligne .
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
110
sebastien176
S
patricktoulon
  • Question
Autres Petite mise a jour (exceptionnellement pour cp4) du calendar V4.1(OLDVERSION)
2
Réponses
21
Affichages
426
patricktoulon
patricktoulon
B
  • Résolu(e)
Microsoft 365 Besoin d'aide pour faire fonctionner 2 codes VBA ensemble
Réponses
2
Affichages
142
BenExcel
B
D
  • Question
Microsoft 365 Application.WorksheetFunction.VLookup ne fonctionne pas au delà de 8500 lignes
Réponses
4
Affichages
301
DimiJuju
D
F
  • Résolu(e)
XL 2021 fermeture du classeur après apple d'un userform d'un autre classeur ouvert
Réponses
2
Affichages
97
farid
F
N
  • Question
Microsoft 365 Imbrication de deux formule Worksheet_BeforeDoubleClick
Réponses
1
Affichages
151
Nathan027
N
T
  • Résolu(e)
XL 2010 VBA - Fonction double clics à opérations multiples
Réponses
2
Affichages
167
Titi456
T
H
  • Question
Microsoft 365 Evénement arrondi au multiple sup
Réponses
6
Affichages
159
hbb
H
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
139
GClaire
G
M
  • Résolu(e)
XL 2016 Private Sub ne fonctionne pas
Réponses
4
Affichages
214
MaNU84510
M

Membres actuellement en ligne

21 membres et 142 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 207
Messages
2 086 252
Membres
103 166
dernier inscrit
ZAHRAA