faire un protocol

**Hoppelbutz** · 20/03/2016, 23h34

Bonjour a tout le monde
je suis un nouveau
et je suis pas un expert dans le vba

J’ai une question sur cette macro que j'avais trouver sur l'internet

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Dim premiercellulelibre As Long
  Dim Ancienvaleur As Variant, Nouvellevaleur As Variant
  Dim rngNeuSel As Range
  If Target.Count > 1 Then Exit Sub
  If Sh.Name = "Protocol" Then Exit Sub
   If Intersect(Target, Sh.Range("A8:Q380")) Is Nothing Then Exit Sub 
  Application.EnableEvents = False
     Nouvellevaleur = Target.Value
  Set rngNeuSel = Selection
  Application.Undo 
    Ancienvaleur = Target.Value
  Target.Value = Nouvellevaleur
  On Error Resume Next
  rngNeuSel.Activate
  On Error GoTo 0
  With Sheets("Protocol")
    Premiercellulelibre  = .Cells(Rows.Count, 1).End(xlUp).Row + 1 
    .Cells(Premiercellulelibre , 1) = Sh.Name 
    .Cells(Premiercellulelibre , 2) = Environ("username") 
    .Cells(Premiercellulelibre , 3) = Date 
    .Cells(Premiercellulelibre , 4) = Time 
    .Cells(Premiercellulelibre , 5) = Target.Address(0, 0) 
    .Cells(Premiercellulelibre , 6) = Ancienvaleur     
    .Cells(Premiercellulelibre , 7) = Target.Value 
        End With
  Application.EnableEvents = True
End Sub

Je veux ajouter dans la macro quand je changer la cellule Exp : B1 qu’il prend aussi la cellule A1 pour mettre dans la feuille Protocol
Voici un exemple en détaille ce que je voulais avoir en plus dans le macro

Cellule:A1--------- cellule:B1-------- cellule:C1 ... etc. etc…. jusque la cellule:L1
Mois1-----------------Mois2-------------Mois3------------------------------Mois12
Exp: quand je taper dans la cellule :B1 (Nouvellevaleur)---(Test) alors je veux qu’il copie aussi la cellule:A1 Mois1 aussi dans le la feuille Protocol
Exp: quand je taper dans la cellule :L5 (Nouvellevaleur)---(grand père) alors je veux qu’il copie aussi la cellule:L1 Mois12 aussi dans le la feuille Protocol
Le reste dans la macro c’est bien.
voici un exemble du fichier

Merci pour votre aide déja en anance

**Docmarti** · 21/03/2016, 02h50

Bonjour.

Tu peux faire comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  Dim premiercellulelibre As Long
  Dim Ancienvaleur As Variant, Nouvellevaleur As Variant
  Dim rngNeuSel As Range
  If Target.Count > 1 Then Exit Sub
  If Sh.Name = "Protocol" Then Exit Sub
   If Intersect(Target, Sh.Range("A2:L30")) Is Nothing Then Exit Sub
 
  Application.EnableEvents = False
  mois = Sh.Cells(1, Target.Column).Value
  Nouvellevaleur = Target.Value
  Set rngNeuSel = Selection
  Application.Undo
    Ancienvaleur = Target.Value
  Target.Value = Nouvellevaleur
  On Error Resume Next
  rngNeuSel.Activate
  On Error GoTo 0
  With Sheets("Protocol")
    premiercellulelibre = .Cells(Rows.Count, 1).End(xlUp).Row + 1
 
    .Range(.Cells(premiercellulelibre, "A"), .Cells(premiercellulelibre, "H")).NumberFormat = "General"
    .Cells(premiercellulelibre, 1) = Sh.Name
    .Cells(premiercellulelibre, 2) = Environ("username")
 
    .Cells(premiercellulelibre, 3).Value = Date
 
    .Cells(premiercellulelibre, 4) = Time
    .Cells(premiercellulelibre, 5) = Target.Address(0, 0)
 
    .Cells(premiercellulelibre, 6) = Ancienvaleur
 
    .Cells(premiercellulelibre, 7) = Target.Value
    .Cells(premiercellulelibre, 8) = mois 'ici sera le mois
   End With
  Application.EnableEvents = True
End Sub

**Hoppelbutz** · 21/03/2016, 12h59

Merci super
Ca fonctionne
j'ai encore une autre question
si je mai la Colonne Mois dans la casse A7 et au dessous mettrai des commentaire comment je pourrait faire cela ?
Merci