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

Version imprimable

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

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:

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