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

Version imprimable

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, 15h24
'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, 15h39
Daniel.C

Oui ça a l'air d'être bon.
16/12/2014, 15h44
'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, 16h27
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, 16h32
'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, 16h38
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, 16h45
'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, 16h59
Daniel.C

Comme le message ne l'indique pas, la colonne doit être vide.
16/12/2014, 17h12
'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, 17h24
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, 08h48
'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, 09h23
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, 16h52
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, 17h22
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 ?
17/12/2014, 17h31
'OTM'

Non en fait je voudrais simplement coller le code suivant en même temps sur les feuilles : ("2N traité") et ("feuille3")

Code:

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

comme un "collé à l'identique" sur deux feuilles différentes...
17/12/2014, 17h40
Daniel.C

Citation:

Non en fait je voudrais simplement coller feuille ("2N traité") et ("feuille3") comme un "collé à l'identique" sur deux feuilles différentes

Ce n'est pas clair pour moi. Tu fais simplement une sélection de cellules visibles. Est-ce que tu veux les copier sur tes deux feuilles ? Et si oui, à quel endroit ? Au même emplacement ?

Bonjour Daniel,

Désolé pour hier soir j'ai du partir précipitamment.
Alors je vais essayer d'être un peur plus clair aujourd'hui.
Dans le code suivant j'aimerai ajouter à "Set sheetToPaste = Worksheets("2N Traité"),une seconde feuille "à coller"Worksheets(feuil2)"
Afin d'avoir un second onglet identique à l'onglet "2N Traité"sans protection cette fois.
Et la grace à toi j'aurai résolu ma demande.:):)

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
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é")',Worksheets("feuil2") si possible
 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

Encore merci de m'accorder du temps.:lol:

Cordialement

Christophe

Citation:

Afin d'avoir un second onglet identique à l'onglet "2N Traité"sans protection cette fois.

Pour ce qui est de la protection, reporte-toi au message #18. Cette macro s'exécute à l'ouverture, ainsi, la protection ne s'applique pas aux macros. Si tu n'en comprends pas la teneur, dis-le. Pour ce qui est des deux feuilles, une solution consiste à créer un array avec le nom des feuilles :

Code:

Feuilles = Array("2N Traité", "feuil2")

et à faire une boucle sur chacune des feuilles :

Code:

1
2
3
For Each Item In Feuilles
'...
Next Item

Ton code modifié devient (non testé) :

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 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
 Dim Feuilles As Variant
 
If Target <> "" Then
 Feuilles = Array("2N Traité", "feuil2")
 For Each Item In Feuilles
    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(Item) ',Worksheets("feuil2") si possible
    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
 Next Item
End If

Bonjour Daniel,

J'ai mis à jour mon code et j'ai l'Erreur de compilation:"Else sans If" taggé sur Else
du code.
On y est :)presque...

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 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
 Dim Feuilles As Variant
 
If Target <> "" Then
 Feuilles = Array("2N Traité", "feuil2")
 For Each Item In Feuilles
    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(Item) ',Worksheets("feuil2") si possible
    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
 Next Item
End If

Bonjour,

A quel "If" se réfère ce Else" ?

Code:

1
2
3
    Range("a" & Target.Row).Resize(1, 40).Locked = True
    Else
    Range("a" & Target.Row).Resize(1, 40).Locked = False

19/12/2014, 10h56
Marc-L

Bonjour, bonjour !

C'est pourtant simple, du niveau de l'école élémentaire ‼

Dans ton code, combien de lignes commençant par If et se terminant par Then ? Et combien de End If ?!

Bonjour,

Citation:

Dans ton code, combien de lignes commençant par If et se terminant par Then ? Et combien de End If ?!

Pour moi, c'est une histoire de placement, ça ne serait pas (sans analyser le contenu)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
If Target <> "" Then
 Feuilles = Array("2N Traité", "feuil2")
 For Each Item In Feuilles
    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(Item) ',Worksheets("feuil2") si possible
    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
 Next Item
    Else
    Range("a" & Target.Row).Resize(1, 40).Locked = False
End If

Bonjour Marc,

Malheureusement je n'en suis qu'à l'élémentaire....:roll:

Mais ce n'est que la première partie du code, le code complet est celui-ci: il doit y maquer une subtilité que je ne connais pas :oops:

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
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
 Dim Feuilles As Variant
 
If Target <> "" Then
 Feuilles = Array("2N Traité", "feuil2")
 For Each Item In Feuilles
    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(Item) ',Worksheets("feuil2") si possible
    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
 Next Item
 
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

casefayere, merci de ton intervention

Erreur d'exécution '91' : Variable objet ou variable de bloc With non définie

taggé sur la partie en gras du code suivant:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
If Target <> "" Then
 Feuilles = Array("2N Traité", "feuil2")
 For Each Item In Feuilles
    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(Item) ',Worksheets("feuil2") si possible
    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
    Next Item
    Else
    Range("a" & Target.Row).Resize(1, 40).Locked = False

End If

19/12/2014, 11h25
casefayere

L'erreur n'est plus la même, donc mon placement est bon mais comme je ne me suis pas plongé dans ton histoire, le reste.......,

Je ne peux pas à ce stade, m'intégrer au fond du problème

Par hasard, est-ce que "lastRow" est bien déclaré et comment ?
19/12/2014, 11h54
'OTM'

casefayere,
je garde ton placemement, et Lastrow est décallé par le surlignage en gras.
19/12/2014, 12h01
casefayere

Ma question n'est pas celle-là, Est-ce que "lastRow" est bien déclaré ?, c'est à dire, en début de module ou ailleurs

Code:

Dim lastRow as....

Casefayere,

Ma feuille ne contient que ce code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
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
 Dim Feuilles As Variant
 
If Target <> "" Then
 Feuilles = Array("2N Traité", "feuil2")
 For Each Item In Feuilles

Code:

Dim lastRow as....

n'est pas déclaré
Cordialement
Christophe

19/12/2014, 13h34
casefayere

Citation:

n'est pas déclaré

d'où l'erreur, alors déclares-le et renvoies le code complet car, comme je l'ai précisé, je n'ai pas suivi tous les fils

Casefayere, voici le code complet

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
 Dim Feuilles As Variant
 
If Target <> "" Then
 Feuilles = Array("2N Traité", "feuil2")
 For Each Item In Feuilles
    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(Item) ',Worksheets("feuil2") si possible
    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
Next Item
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

Cordialement

voilà comment j'aurai rédigé le début, en déclarant lastrow en range

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 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, lastRow As Range
 Dim Feuilles As Variant
 
If Target <> "" Then
  Feuilles = Array("2N Traité", "feuil2")
  For Each Item In Feuilles
    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).Copy
    Set sheetTemp = ActiveSheet
    Set sheetToPaste = Worksheets(Item) ',Worksheets("feuil2") si possible
    sheetToPaste.Activate
    Set lastRow = sheetToPaste.Columns(1).Find(What:="*", SearchDirection:=xlPrevious)
    If Not lastRow Is Nothing Then
      sheetToPaste.Range("A" & lastRow.Row + 1).PasteSpecial Paste:=xlPasteValues
      Set rng = sheetToPaste.Range("A2", "Q" & lastRow.Row + 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.Range("a" & Target.Row).Resize(1, 40).Locked = True
    End If
  Next Item
Else
    Range("a" & Target.Row).Resize(1, 40).Locked = False
End If

le reste du code est à adapter surtout quand on fait référence à lastrow (déclaré en "Range"), regardes bien ce qui change ci-dessus

19/12/2014, 14h21
'OTM'

Casefayere,

Tout d'abord merci à toi et félicitations, ma demande est résolue.
Merci à Daniel.C qui m'a fait avancer à grands pas.:lol::lol::lol::lol::lol::lol::lol: