Ajouter une "Target" à Private Sub Worksheet_Change(ByVal Target As Range)

Version imprimable

Voir 40 message(s) de cette discussion en une page

Bonjour à toutes et à tous,

Je suis débutant, je travaille avec une macro qui toune à merveille, j'aimerai simplement ajouter en copie la feuille2 de cette macro puis une "Target"en "AF"et copier ma nouvelle sélection en feuille3.
et vérouiller par le même mot de passe mes feuilles (1,3, base). mais c'est pas facile pour un débutant. :roll:

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
Private Sub Worksheet_Change(ByVal Target As Range)
        If Intersect(Target, Columns("AE")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
        ActiveSheet.Unprotect Password:="TEST"
        Dim sheetTemp As Worksheet
        Dim sheetToPaste As Worksheet
        Dim rng As Range
 
        If Target <> "" Then
            Range("J" & Target.Row).Value = Now()
            Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            Set sheetTemp = ActiveSheet
            Set sheetToPaste = Worksheets("Feuil1")
            sheetToPaste.Activate
            lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
            sheetToPaste.Range("A" & lastRow + 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Set rng = sheetToPaste.Range("A2", "Q" & lastRow + 2)
            rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlNo
            sheetTemp.Activate
                    Range("a" & Target.Row).Resize(1, 40).Locked = True
        Else
            Range("a" & Target.Row).Resize(1, 40).Locked = False
 
 
        End If
            ActiveSheet.Protect Password:="TEST"
 
 
End Sub

Merci de votre précieuse aide:D:D:D:D

Bonjour,

Pas sûr d'avoir bien compris. Ton code pourrait s'articuler comme suit :

Code:

1
2
3
4
5
6
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 31 And Target.Cells.Count = 1 Then '(Target.Count = 1 le fait aussi)
    'ton code
ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then
    'ton code
End If

et, pour les mots de passe :

Code:

1
2
3
Sheets("1").Protect Password:="TEST"
Sheets("3").Protect Password:="TEST"
Sheets("base").Protect Password:="TEST"

16/12/2014, 16h24
'OTM'

1 pièce(s) jointe(s)

Re bonjour Daniel,

j'ai malheureusement erreur de compilation "Else sans IF"

Code:

ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then.

J'espère avoir bien compris , ci joint le code mis à jour.

Pièce jointe 164013

Cdt
16/12/2014, 16h39
Daniel.C

Oui ça a l'air d'être bon.
16/12/2014, 16h44
'OTM'

Bien malheureusement erreur de compilation "Else sans IF", sur la seconde partie du code :

Code:

ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then

:calim2::weird::calim2:

Il manque un "End If" avant le ElseIf :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
    If Target <> "" Then
        Range("J" & Target.Row).Value = Now()
        Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
        Selection.Copy
        Set sheetTemp = ActiveSheet
        Set sheetToPaste = Worksheets("Feuil1")
        sheetToPaste.Activate
        lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
        sheetToPaste.Range("A" & lastRow + 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues
        Set rng = sheetToPaste.Range("A2", "Q" & lastRow + 2)
        rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlNo
        sheetTemp.Activate
        Range("a" & Target.Row).Resize(1, 40).Locked = True
     Else
     Range("a" & Target.Row).Resize(1, 40).Locked = False
'******************** ICI***************************************
ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then

J'ai corrigé et maintenant j'ai Erreur de compilation:

Déclaration existante dans la portée en cours:

Code:

1
2
3
ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then
ActiveSheet.Unprotect Password:="TEST"
 Dim sheetTemp As Worksheet

:ptdr:;);)

j'espère ne pas avoir fait d'erreur cette fois

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
Private Sub Worksheet_Change(ByVal Target As Range)
  
 If Target.Column = 31 And Target.Cells.Count = 1 Then '(Target.Count = 1 le fait aussi)
 ActiveSheet.Unprotect Password:="TEST"
 Dim sheetTemp As Worksheet
 Dim sheetToPaste As Worksheet
 Dim sheetToPaste2 As Worksheet
 Dim rng As Range
 
If Target <> "" Then
 Range("J" & Target.Row).Value = Now()
 Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy
 Set sheetTemp = ActiveSheet
 Set sheetToPaste = Worksheets("Feuil1")
 sheetToPaste.Activate
 lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
 sheetToPaste.Range("A" & lastRow + 1).Select
 Selection.PasteSpecial Paste:=xlPasteValues
 Set rng = sheetToPaste.Range("A2", "Q" & lastRow + 2)
 rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlNo
 sheetTemp.Activate
 Range("a" & Target.Row).Resize(1, 40).Locked = True
 Else
 Range("a" & Target.Row).Resize(1, 40).Locked = False

End If

ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then
ActiveSheet.Unprotect Password:="TEST"
 Dim sheetTemp As Worksheet
 Dim sheetToPaste As Worksheet
 Dim sheetToPaste2 As Worksheet
 Dim rng As Range
 
If Target <> "" Then
 Range("J" & Target.Row).Value = Now()
 Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy
 Set sheetTemp = ActiveSheet
 Set sheetToPaste = Worksheets("Feuil2")
 sheetToPaste.Activate
 lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
 sheetToPaste.Range("A" & lastRow + 1).Select
 Selection.PasteSpecial Paste:=xlPasteValues
 Set rng = sheetToPaste.Range("A2", "Q" & lastRow + 2)
 rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlNo
 sheetTemp.Activate
 Range("a" & Target.Row).Resize(1, 40).Locked = True
 Else
 Range("a" & Target.Row).Resize(1, 40).Locked = False

  End If
 Sheets("Base").Protect Password:="TEST"
Sheets("Feuil1").Protect Password:="TEST"
Sheets("Feuil2").Protect Password:="TEST"

End Sub

Cdt

16/12/2014, 17h27
Daniel.C

Citation:

Déclaration existante dans la portée en cours:

C'est du langage Microsoft pour dire que tu déclares plusieurs fois la même variable.
Il ne faut pas que tu répètes tes déclarations (Dim...). Tu ne peux les faire qu'une fois par macro. C'est d'ailleurs suffisant.
16/12/2014, 17h32
'OTM'

Donc je supprime DIM de la seconde partie du code après :

Code:

ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then

Pas façile d'avoir affaire à un débutant désolé :oops:
16/12/2014, 17h38
Daniel.C

Citation:

Donc je supprime DIM de la seconde partie du code après :

Code:

ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then

Tout à fait.

Citation:

Pas façile d'avoir affaire à un débutant

"L'homme arrive novice à chaque âge de la vie."

Chamfort

Donc, pas de problème, on est tous passé par là. ;
16/12/2014, 17h45
'OTM'

1 pièce(s) jointe(s)

La première partie du script fonctionne parfaitement , mais la seconde j'ai enlevé DIM répétés et lorsque je sélectionne ma liste déroulante colonne"32" message erreur d'exécution '91': Variable objet ou variable de bloc With non défini. pour

Code:

lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row

Ci-joint le code modifié:
Cdt:roll:Pièce jointe 164022
16/12/2014, 17h59
Daniel.C

Comme le message ne l'indique pas, la colonne doit être vide.
16/12/2014, 18h12
'OTM'

Vraiment merci beaucoup pour votre patience et votre dévouement.

Alléluia!!!
Finalement en mettant un titre à chaque colonne de ma feuille 2 cela fonctionne, il ne me reste plus qu'à finaliser les mots de passe qui eux me donnent du fil à retordre. erreur 9 : l'indice n'appartient pas à la sélection.
Je suis à la bourre!!!^^:mouarf::mouarf:
16/12/2014, 18h24
Daniel.C

Citation:

erreur 9 : l'indice n'appartient pas à la sélection

Ca veut dire que le nom de la feuille n'est pas le bon.
17/12/2014, 09h48
'OTM'

1 pièce(s) jointe(s)
Bonjour Daniel, :)

J'ai bien essayé de placer à différents endroits:

Code:

ActiveSheet.Unprotect Password:="TEST"

et
Code:

1 2 3 Sheets("1").Protect Password:="TEST" Sheets("2").Protect Password:="TEST" Sheets("base").Protect Password:="TEST"
la seule solution est de désactiver la protection de la feuille, cela fonctionne , mais je peux alors modifier toutes mes cellules.:(

Mais impossible au final d'avoir toutes mes feuilles verrouillées (pour ne pas "polluer" mes informations).:?
et pour résoudre mon classeur il me manque aussi la copie de la feuille1 dans une autre feuille (un collé identique de la feuille1):roll:
Pour le reste tout va bien.:)
Cdt
Pièce jointe 164075
17/12/2014, 10h23
Daniel.C
Bonjour,
Citation:
J'ai bien essayé de placer à différents endroits:

Code:

ActiveSheet.Unprotect Password:="TEST"

et

Code:

1 2 3 Sheets("1").Protect Password:="TEST" Sheets("2").Protect Password:="TEST" Sheets("base").Protect Password:="TEST"

la seule solution est de désactiver la protection de la feuille, cela fonctionne , mais je peux alors modifier toutes mes cellules.
Tu les déprotèges juste le temps de l'exécution de la macro et tu les reprotèges ensuite. Sinon, tu peux les protéger comme ceci :

Code:

Sheets("1").Protect Password:="TEST", Userinterfaceonly=True

Re Bonjour Daniel,

j'ai le code erreu suivant : Erreur de compilation: attendu: paramètre nommé

Code:

Sheets("2N Traité").Protect Password:="TEST", Userinterfaceonly=True

décidément je vais pas pouvoir me proèger...;)

à l'heure actuelle je ne sais plus ou placer mes (ActiveSheet.protect Password:="TEST") pour que ça fonctionne correctement comme avec ce code actuel

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
Private Sub Worksheet_Change(ByVal Target As Range)
 
 If Target.Column = 31 And Target.Cells.Count = 1 Then '(Target.Count = 1 le fait aussi)
 ActiveSheet.Unprotect Password:="TEST"
 Dim sheetTemp As Worksheet
 Dim sheetToPaste As Worksheet
 Dim sheetToPaste2 As Worksheet
 Dim rng As Range
 
If Target <> "" Then
 Range("J" & Target.Row).Value = Now()
 Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy
 Set sheetTemp = ActiveSheet
 Set sheetToPaste = Worksheets("2N Traité")
 sheetToPaste.Activate
 lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
 sheetToPaste.Range("A" & lastRow + 1).Select
 Selection.PasteSpecial Paste:=xlPasteValues
 Set rng = sheetToPaste.Range("A2", "Q" & lastRow + 2)
 rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlNo
 sheetTemp.Activate
 Range("a" & Target.Row).Resize(1, 40).Locked = True
 Else
 Range("a" & Target.Row).Resize(1, 40).Locked = False
 
End If
 
 
ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then
ActiveSheet.Unprotect Password:="TEST"
 
If Target <> "" Then
 Range("J" & Target.Row).Value = Now()
 Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy
 Set sheetTemp = ActiveSheet
 Set sheetToPaste = Worksheets("Dossiers Manquants")
 sheetToPaste.Activate
 lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
 sheetToPaste.Range("A" & lastRow + 1).Select
 Selection.PasteSpecial Paste:=xlPasteValues
 Set rng = sheetToPaste.Range("A2", "H" & lastRow + 2)
 rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlNo
 sheetTemp.Activate
 Range("a" & Target.Row).Resize(1, 40).Locked = True
 Else
 Range("a" & Target.Row).Resize(1, 40).Locked = False
 
End If
 
End If
Sheets("2N Traité").Protect Password:="TEST", Userinterfaceonly=True
End Sub

De plus j'aimerai coller sur une autre feuille la macro ("2Ntraité"),j'ai essayé de recopier le code mais erreur, j'ai essayé d'intégrer une seconde

Code:

Set sheetToPaste = Worksheets("Feuil3")

sans succés. heureusement que le ciel est gris pour rester concentré.:weird:

17/12/2014, 17h52
Daniel.C
Désolé, la bonne syntaxe est :

Code:

Sheets("2N Traité").Protect Password:="TEST", Userinterfaceonly:=True

Dans le module "ThisWorkbook", tu ôtes la protectiion de tes feuilles, uniquement pour les macros avec :
Code:

1 2 3 4 Private Sub Workbook_Open() Sheets("2N Traité").Protect Password:="TEST", Userinterfaceonly:=True ' pareil pour les autres feuilles End Sub
Après, tu n'as plus à te soucier de déprotéger ou protéger tes feuilles.

Citation:

De plus j'aimerai coller sur une autre feuille la macro ("2Ntraité"),j'ai essayé de recopier le code mais erreur, j'ai essayé d'intégrer une seconde

Poste ton code.

Re bonjour Daniel,

Génial ça fonctionne enfin très bien avec ce nouveau code merci.
Je vois le bout du tunel...:)
Il ne reste plus qu'à savoir comment coller sur une seconde feuille, le code identique

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub Worksheet_Change(ByVal Target As Range)
 
 If Target.Column = 31 And Target.Cells.Count = 1 Then '(Target.Count = 1 le fait aussi)
 ActiveSheet.Unprotect Password:="TEST"
 Dim sheetTemp As Worksheet
 Dim sheetToPaste As Worksheet
 Dim sheetToPaste2 As Worksheet
 Dim rng As Range
 
If Target <> "" Then
 Range("J" & Target.Row).Value = Now()
 Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy
 Set sheetTemp = ActiveSheet
 Set sheetToPaste = Worksheets("2N Traité")'''''''''& Worksheet("feuil3")''''''''???
 sheetToPaste.Activate

Voici le code final qui fonctionne très bien grace à toi merci mille fois ;)

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
Private Sub Worksheet_Change(ByVal Target As Range)
 
 If Target.Column = 31 And Target.Cells.Count = 1 Then '(Target.Count = 1 le fait aussi)
 ActiveSheet.Unprotect Password:="TEST"
 Dim sheetTemp As Worksheet
 Dim sheetToPaste As Worksheet
 Dim sheetToPaste2 As Worksheet
 Dim rng As Range
 
If Target <> "" Then
 Range("J" & Target.Row).Value = Now()
 Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy
 Set sheetTemp = ActiveSheet
 Set sheetToPaste = Worksheets("2N Traité")
 sheetToPaste.Activate
 lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
 sheetToPaste.Range("A" & lastRow + 1).Select
 Selection.PasteSpecial Paste:=xlPasteValues
 Set rng = sheetToPaste.Range("A2", "Q" & lastRow + 2)
 rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17), Header:=xlNo
 sheetTemp.Activate
 Range("a" & Target.Row).Resize(1, 40).Locked = True
 Else
 Range("a" & Target.Row).Resize(1, 40).Locked = False
 
End If
 
ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then
ActiveSheet.Unprotect Password:="TEST"
 
If Target <> "" Then
 Range("J" & Target.Row).Value = Now()
 Application.Union(Range("A" & Target.Row & ":E" & Target.Row), Range("J" & Target.Row & ":J" & Target.Row), Range("X" & Target.Row & ":X" & Target.Row), Range("AD" & Target.Row & ":AE" & Target.Row), Range("AG" & Target.Row & ":AN" & Target.Row)).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy
 Set sheetTemp = ActiveSheet
 Set sheetToPaste = Worksheets("Dossiers Manquants")
 sheetToPaste.Activate
 lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
 sheetToPaste.Range("A" & lastRow + 1).Select
 Selection.PasteSpecial Paste:=xlPasteValues
 Set rng = sheetToPaste.Range("A2", "H" & lastRow + 2)
 rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlNo
 sheetTemp.Activate
 Range("a" & Target.Row).Resize(1, 40).Locked = True
 Else
 Range("a" & Target.Row).Resize(1, 40).Locked = False
 
End If
 
End If
Sheets("2N Traité").Protect Password:="TEST", Userinterfaceonly:=True
Sheets("Dossiers Manquants").Protect Password:="TEST", Userinterfaceonly:=True
Sheets("Base BI ").Protect Password:="TEST", Userinterfaceonly:=True
End Sub

17/12/2014, 18h22
Daniel.C

Condition pour 1ère copie :

Code:

If Target.Column = 31 And Target.Cells.Count = 1 Then '(Target.Count = 1 le fait aussi)

Condition ppour deuxième copoie :

Code:

ElseIf Target.Column = 32 And Target.Cells.Count = 1 Then

Quelle est la condition pour la 3e copie ?

Voir 40 message(s) de cette discussion en une page