faire un protocol

Version imprimable

1 pièce(s) jointe(s)

faire un protocol

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:

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

Bonjour.

Tu peux faire comme ceci :

Code:

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

21/03/2016, 11h59
Hoppelbutz

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
21/03/2016, 14h26
Docmarti

Il faudrait donner un exemple précis de ce que tu veux faire.
21/03/2016, 15h34
Hoppelbutz

1 pièce(s) jointe(s)

Merci Docmarti.
Voici le fichier comme je pensait de l'avoir

Merci
pour ton aide
21/03/2016, 19h22
Hoppelbutz

Bonsoir
j'ai trouver

javais seulement besoin de changer cela

Code:

mois = Sh.Cells(6, Target.Column).Value

Merci
23/03/2016, 10h01
Hoppelbutz

1 pièce(s) jointe(s)

bonjour
j'ai encore un autre soucie
je voulait encore une ajoute une Colonne ont plus devant dans le fichier :calim2:
j'arrive pas à définir que le macro lis cet colonne j'avais déjà fait des essai mai il vas toujours ver le bas mai moi je voulez allez vers le gauche.:(
Merci
j'ai ajoute le fichier.

Bonjour.

Voici une nouvelle version.

Code:

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
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim premiercellulelibre As Long
    Dim Ancienvaleur As Variant, Nouvellevaleur As Variant
    Dim mois As Variant
    Dim Date_Jours As Variant
    Dim What As Variant
    Dim Origine As Object
    Dim Destination As Object
 
    If Target.Count > 1 Then Exit Sub
    If Sh.Name = "Protocol" Then Exit Sub
    If Intersect(Target, Sh.Range("A7:M35")) Is Nothing Then Exit Sub
 
    Set Origine = Target
 
    Application.EnableEvents = False
 
 
    Nouvellevaleur = Origine.Value
 
    Application.Undo
 
    Ancienvaleur = Origine.Value
 
    Origine.Value = Nouvellevaleur
 
 
    With Sheets("Protocol")
        premiercellulelibre = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
 
        What = Sh.Name
        Set Destination = .Cells(premiercellulelibre, "A")
        Call transfererVersCelluleDestination(What, Destination)
 
        What = Environ("username")
        Set Destination = .Cells(premiercellulelibre, 2)
        Call transfererVersCelluleDestination(What, Destination)
 
        What = Date
        Set Destination = .Cells(premiercellulelibre, 3)
        Call transfererVersCelluleDestination(What, Destination)
 
        What = Time
        Set Destination = .Cells(premiercellulelibre, 4)
        Call transfererVersCelluleDestination(What, Destination)
 
        What = Origine.Address(0, 0)
        Set Destination = .Cells(premiercellulelibre, 5)
        Call transfererVersCelluleDestination(What, Destination)
 
        What = Ancienvaleur
        Set Destination = .Cells(premiercellulelibre, 6)
        Call transfererVersCelluleDestination(What, Destination)
 
        What = Origine.Value
        Set Destination = .Cells(premiercellulelibre, 7)
        Call transfererVersCelluleDestination(What, Destination)
 
        mois = Sh.Cells(6, Origine.Column).Value
        What = mois
        Set Destination = .Cells(premiercellulelibre, 8)
        Call transfererVersCelluleDestination(What, Destination)
 
        Date_Jours = Sh.Cells(Origine.Row, 1).Value
        What = Date_Jours
        Set Destination = .Cells(premiercellulelibre, 9)
        Call transfererVersCelluleDestination(What, Destination)
 
    End With
    Application.EnableEvents = True
End Sub
 
Sub transfererVersCelluleDestination(What, Destination)
 
    If TypeName(What) = "String" Then
        Destination.NumberFormat = "@"
    Else
        Destination.NumberFormat = "General"
    End If
 
    Destination.Value = What
End Sub

23/03/2016, 14h22
Hoppelbutz

Bonjour
Merci ca fonction
Tu est un Génie
Sait vraiment complique

Merci 1000x