Lancement d'une méthode Find à partir d'un double-clic

**Lyreco** · 16/07/2014, 17h05

Bonjour à tous,
Je me permets de vous solliciter car j’ai quelques difficultés dans la réalisation d’une macro. Loin d’être expert, je récupère des morceaux de code que j’adapte à mon cas, sans toujours comprendre à 100% son contenu.

Je vous expose la chose :
Un classeur, 2 onglets
Dans l’onglet 1, l’idée consiste à double cliquer pour cocher une cellule d’un « x », ce qui engendre des modifications dans l’onglet 2 (insertion de ligne + copier-coller d’informations de l’onglet 1).
Je patauge en raison de l’utilisation des coordonnées relatives. J’illustre par 2 images les onglets et je vous montre mon code en l’état actuel.

Onglet 1

Onglet 2

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
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
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
'Variables partie 2
Dim Trouve As Range, PlageDeRecherche As Range 
Dim Valeur_Cherchee As String, AdresseTrouvee As String 
 
 
'Partie 1 : Coche un X dans la cellule en double clic
If Not Application.Intersect(Target, Range("C3:BG448")) Is Nothing Then
On Error Resume Next
If IsEmpty(ActiveCell.Value) Then
ActiveCell.Value = "x"
ElseIf ActiveCell.Value = "x" Then
ActiveCell.Value = ""
End If
Cancel = True
End If
 
'Partie 2 : Cherche valeur cellule : même ligne & colonne 1 de l’onglet 1 dans l’onglet 2
'Affectation de valeurs aux variables : Recherche première cellule de la ligne cochée de l’onglet 1
Valeur_Cherchee = ActiveCell.EntireRow.Cells(1)
'Indication de la plage de recherche : colonne L de l’onglet 2
Set PlageDeRecherche = Sheets("onglet 2").Columns(12) 
 
'Méthode find
Set Trouve = PlageDeRecherche.Cells.Find(what:=Valeur_Cherchee, LookAt:=xlWhole).Activate
 
'Partie 3: Si la valeur n’est pas trouvée dans l’onglet 2 colonne L
If Trouve Is Nothing Then
AdresseTrouvee = Valeur_Cherchee & " n'est pas présent dans " & PlageDeRecherche.Address 
 
MsgBox AdresseTrouvee 
 
 
'Partie 4 : Si la valeur est trouvée dans l’onglet 2 colonne L
Else 
AdresseTrouvee = Trouve.Address
 
'Partie 5 : Modifications sur l’onglet 2
'Insertion d’une ligne en dessous de la valeur trouvée
Sheets("Onglet 2").Select
Entire.Rows("AdresseTrouvee").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
'Remise à 0 des variables 
 
Set PlageDeRecherche = Nothing 
Set Trouve = Nothing 
 
'Copier-coller de l’activité de l’onglet 1 vers l’onglet 2
Sheets("Onglet 1").Activate
'Copie la valeur cellule : Colonne B ; même ligne que la coche « x »
ActiveCell.EntireRow.Cells(2).copy
'Colle la valeur cellule : Colonne K ; ligne nouvellement insérée
Sheets("Onglet 2").Activate
ActiveCell.EntireRow.Cells(11).Activate
ActiveSheet.PasteSpecial  Paste:=xlPasteValues
 
'Copier-coller de la  thématique de l’onglet 1 vers l’onglet 2
Sheets("Onglet 1").Activate
'Copie la valeur cellule : Ligne 1 ; même colonne que la coche « x »
ActiveCell.EntireColumn.Cells(1).copy
'Colle la valeur cellule : Colonne N ; ligne nouvellement insérée
Sheets("Onglet 2").Activate
ActiveCell.EntireRow.Cells(14).Activate
ActiveSheet.PasteSpecial  Paste:=xlPasteValues
 
'Copier-coller du risque lié de l’onglet 1 vers l’onglet 2
Sheets("Onglet 1").Activate
'Copie la valeur cellule : Ligne 2 ; même colonne que la coche « x »
ActiveCell.EntireColumn.Cells(2).copy
'Colle la valeur cellule : Colonne O ; ligne nouvellement insérée
Sheets("Onglet 2").Activate
ActiveCell.EntireRow.Cells(15).Activate
ActiveSheet.PasteSpecial  Paste:=xlPasteValues
 
End If 
End Sub

Au delà du coté sans doute trop basique de mon code (j'apprends seul), l'insertion de ligne ne se fait pas correctement dans l'onglet 2.

D'autre part, il peut y avoir plusieurs fois la valeur recherchée dans l'onglet 2, il faut donc que j'intègre une boucle à cette macro pour que les modifications se fassent sur toutes les valeurs identiques, cependant il y a des lignes masquées sur lesquelles le "find" ne doit pas se faire...

Ce qui m'importe c'est surtout de comprendre même si en conséquence le code n'est pas hyper optimisé... chaque chose en son temps!
Je remercie donc toute âme charitable souhaitant me faire profiter de ses compétences.

Bien à vous.

Edit:
Bonjour à tous,

56 visites sans réponses, a priori mon problème n'inspire pas grand monde...

ou manque de précision.
En respect des articles III-C et IV-G du règlement, je me permets de préciser la demande (remarque au cas où: je ne souhaite pas qu'on fasse le boulot à ma place si c'est ce qui inquiète !)
Voici ce que j'obtiens au lancement du double-clic :

Pourtant la référence est bien présente en L14 et L38 ce qui implique que ma méthode Find ne fonctionne pas correctement... Quelqu'un connait la raison?
Le reste fonctionne presque comme souhaité, je me demande s'il est possible d'appliquer les modifications à toutes les valeurs trouvées à partir du Find sans faire de boucle? Si oui est ce que ça impactera les lignes masquées?

Merci de votre aide!

**AlainTech** · 27/07/2014, 00h27

Bonjour,

Code :

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

Set Trouve = PlageDeRecherche.Cells.Find(what:=Valeur_Cherchee, LookAt:=xlWhole).Activate

Que vient faire le .Activate à la fin?

**Lyreco** · 28/07/2014, 14h01

Bonjour,

Il s'agit d'une tentative malencontreuse, j'ai essayé plusieurs solutions pour tenter de comprendre leur incidence dont :

Code :

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

Set Trouve = PlageDeRecherche.Cells.Find(What:=Valeur_Cherchee, LookAt:=xlWhole)

Copie les valeurs mais à la mauvaise ligne (première ligne du tableau ce qui signifie que le find n'identifie pas les valeurs dans la colonne L

Code :

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

Set Trouve = PlageDeRecherche.Cells.Find(What:=Valeur_Cherchee, LookAt:=xlWhole).Select

Code :

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

Set Trouve = PlageDeRecherche.Cells.Find(What:=Valeur_Cherchee, LookAt:=xlWhole).Activate

N'identifie pas les valeurs = message "non trouvé" dans la colonne L (cf. edit)

Bien à vous.

**AlainTech** · 05/08/2014, 18h57

Bonjour,

Ne sachant si ton problème a évolué depuis ta dernière réponse, je continue la lecture de ton code.

Bien que, dans le cas présent, ça aura peu d'incidence, évite d'utiliser ActiveCell. Dans l'événement BeforeDoubleClick, tu as l'objet Target à ta disposition.

Pour moi, AdresseTrouvee n'a ps d'utilité.

Enfin, et je m'arrêterai là en attendant de savoir où tu en es, il faut absolument éviter le Select.
Voici ce que je te propose pour l'insertion:

Code :

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

1
2
3
'Partie 5 : Modifications sur l’onglet 2
'Insertion d’une ligne en dessous de la valeur trouvée
Trouve.Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Dis-nous si ça fonctionne mieux.

**Lyreco** · 26/08/2014, 10h51

Bonjour,

Avant tout merci d'avoir passé un peu de temps sur mon problème qui n'évolue pas fonctionnellement pour le moment.
Modifications apportées :

Suppression de AdresseTrouvee
Remplacement de la partie 5 par le code proposé.

Le double clique aboutit systématiquement au message box qui me signale que le code recherché n'est pas trouvé dans la colonne L de l'onglet 2.

Voici le code en l'état actuel

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
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
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
'Variables partie 2
Dim Trouve As Range, PlageDeRecherche As Range
Dim Valeur_Cherchee As String
 
 
'Partie 1 : Coche un X dans la cellule en double clic
If Not Application.Intersect(Target, Range("C3:BG448")) Is Nothing Then
On Error Resume Next
If IsEmpty(ActiveCell.Value) Then
ActiveCell.Value = "x"
ElseIf ActiveCell.Value = "x" Then
ActiveCell.Value = ""
End If
Cancel = True
End If
 
'Partie 2 : Cherche valeur cellule : même ligne & colonne 1 de l'onglet1 dans l'onglet2
'Affectation de valeurs aux variables : Recherche colonne A sur la même ligne de l'onglet1
Valeur_Cherchee = ActiveCell.EntireRow.Cells(1)
'Indication de la plage de recherche : colonne L de l'onglet2
Set PlageDeRecherche = Sheets("onglet 2").Columns(12)
 
'méthode find, ici on cherche la valeur exacte, donc :(LookAt:=xlWhole)
Set Trouve = PlageDeRecherche.Cells.Find(What:=Valeur_Cherchee, LookAt:=xlWhole).Activate
Sheets("onglet 1").Select
'Partie 3: Si la valeur n'est pas trouvée dans l'onglet 2 colonne L
If Trouve Is Nothing Then
MsgBox Valeur_Cherchee & " n'est pas présent dans " & PlageDeRecherche.Address
 
Else
'Partie 5 : Modifications sur l’onglet 2
'Insertion d’une ligne en dessous de la valeur trouvée
Trouve.Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
'Vidage des variables
 
Set PlageDeRecherche = Nothing
Set Trouve = Nothing
 
'Copier-coller de l'activité de l'onglet 1 vers l'onglet 2
Sheets("onglet 1").Activate
'Copie la valeur cellule : Colonne B ; même ligne que la coche " x "
ActiveCell.EntireRow.Cells(2).Copy
'Colle la valeur cellule : Colonne K ; ligne nouvellement insérée
Sheets("onglet 2").Activate
ActiveCell.EntireRow.Cells(11).Activate
ActiveSheet.PasteSpecial
 
'Copier-coller de la  thématique de l'onglet 1 vers l'onglet 2
Sheets("onglet 1").Activate
'Copie la valeur cellule : Ligne 1 ; même colonne que la coche " x "
ActiveCell.EntireColumn.Cells(1).Copy
'Colle la valeur cellule : Colonne N ; ligne nouvellement insérée
Sheets("onglet 2").Activate
ActiveCell.EntireRow.Cells(14).Activate
ActiveSheet.PasteSpecial
 
'Copier-coller du risque lié de l'onglet 1 vers l'onglet 2
Sheets("onglet 1").Activate
'Copie la valeur cellule : Ligne 2 ; même colonne que la coche " x "
ActiveCell.EntireColumn.Cells(2).Copy
'Colle la valeur cellule : Colonne O ; ligne nouvellement insérée
Sheets("onglet 2").Activate
ActiveCell.EntireRow.Cells(15).Activate
ActiveSheet.PasteSpecial
End If
End Sub

Bonne journée

~~Un petit fichier exemple pour faciliter la compréhension.~~

**SfJ5Rpw8** · 26/08/2014, 12h15

bonjour,

qu'attends tu pour apporter les corrections proposées plus haut ?

suppression des Active.. Cell ou autre Active , Select ....Selection...

Suppression de ton .Activate dans ta requête find ?.

**Lyreco** · 26/08/2014, 14h30

Bonjour,

Désolé Chef, la pièce jointe n'a visiblement pas plu. Je rappelle pour lever le trouble : post n°1

Ce qui m'importe c'est surtout de comprendre

En conséquence à la question :

qu'attends tu pour apporter les corrections proposées plus haut ?

De comprendre

J'apprends sans source particulière, à raison des petits creux d'agenda et au fil de mes recherches sur internet...

J'ai supprimé le .Activate de la méthode Find. Il ne se passe plus rien au double-clique.

AlainTech a précisé que la modification des ActiveCell n'aurait que peu de conséquences. Par quoi remplacer mes ActiveCell? D'après mes recherches, l'événement Target permet de lancer une procédure Sub à une cellule ou une plage d'une feuille... Ok mais concrétement? J'ai tenté la suppression des ActiveCell et le double clique ne lance plus rien.

Bien à vous

Edit:
Et voici la modification des ActiveCell, espérant avoir bien fait

et comme indiqué sans résultat pour le moment:

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
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
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 
'Variables partie 2
Dim Trouve As Range, PlageDeRecherche As Range
Dim Valeur_Cherchee As String
 
 
'Partie 1 : Coche un X dans la cellule en double clic
If Not Application.Intersect(Target, Range("C3:BG448")) Is Nothing Then
On Error Resume Next
If IsEmpty(Target) Then
Target = "x"
ElseIf Target = "x" Then
Target = ""
End If
Cancel = True
End If
 
'Partie 2 : Cherche valeur cellule : même ligne & colonne 1 de l'Onglet 2 dans l'Onglet 1
'Affectation de valeurs aux variables : Recherche colonne A sur la même ligne de l'Onglet 2
Valeur_Cherchee = Target.EntireRow.Cells(1)
'Indication de la plage de recherche : colonne L de l'Onglet 1
Set PlageDeRecherche = Sheets("Onglet 1").Columns(12)
 
'méthode find, ici on cherche la valeur exacte, donc :(LookAt:=xlWhole)
Set Trouve = PlageDeRecherche.Cells.Find(what:=Valeur_Cherchee, lookat:=xlWhole)
Sheets("Onglet 1").Select
'Partie 3: Si la valeur n'est pas trouvée dans l'Onglet 1 colonne L
If Trouve Is Nothing Then
MsgBox Valeur_Cherchee & " n'est pas présent dans " & PlageDeRecherche.Address
 
Else
'Partie 5 : Modifications sur l’onglet Onglet 1
'Insertion d’une ligne en dessous de la valeur trouvée
Trouve.Offset(1, 0).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
'Vidage des variables
 
Set PlageDeRecherche = Nothing
Set Trouve = Nothing
 
'Copier-coller de l'activité de l'Onglet 2 vers l'Onglet 1
Sheets("Onglet 2").Activate
'Copie la valeur cellule : Colonne B ; même ligne que la coche " x "
Target.EntireRow.Cells(2).Copy
'Colle la valeur cellule : Colonne K ; ligne nouvellement insérée
Sheets("Onglet 1").Activate
Target.EntireRow.Cells(11).Activate
ActiveSheet.PasteSpecial
 
'Copier-coller de la  thématique de l'Onglet 2 vers l'Onglet 1
Sheets("Onglet 2").Activate
'Copie la valeur cellule : Ligne 1 ; même colonne que la coche " x "
Target.EntireColumn.Cells(1).Copy
'Colle la valeur cellule : Colonne N ; ligne nouvellement insérée
Sheets("Onglet 1").Activate
Target.EntireRow.Cells(14).Activate
ActiveSheet.PasteSpecial
 
'Copier-coller du risque lié de l'Onglet 2 vers l'Onglet 1
Sheets("Onglet 2").Activate
'Copie la valeur cellule : Ligne 2 ; même colonne que la coche " x "
Target.EntireColumn.Cells(2).Copy
'Colle la valeur cellule : Colonne O ; ligne nouvellement insérée
Sheets("Onglet 1").Activate
Target.EntireRow.Cells(15).Activate
ActiveSheet.PasteSpecial
End If
End Sub

Lancement d'une méthode Find à partir d'un double-clic

Macros et VBA Excel

Discussions similaires

Partager

Partager