VBA pour copier/coller une rechercheV

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
jeromeN95

jeromeN95

XLDnaute Impliqué
Bonjour,
J'aimerai que lorsque je choisi en colonne A, une valeur situer dans une liste déroulante de choix,
Tout le contenue de la ligne (situer dans la feuille "Quoi") y soit recopier.

J'ai mis un exemple SVP.
 

Pièces jointes

Trier par date Trier par votes
Re : VBA pour copier/coller une rechercheV

Bonjour Jérôme,

J'avais commencé par cette macro :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim plage As Range, s As Object
Dim i&, t$
Application.ScreenUpdating = 0: Application.EnableEvents = 0
If Target.Column = 1 And Target.Row > 4 And Target.Count = 1 Then
  t = Target: i = Target.Row
'Suppression des images de la ligne modifiée
   For Each s In ActiveSheet.Shapes
    Set plage = Range(Cells(i, 3), Cells(i, 15))
    On Error Resume Next
     If Not Intersect(s.TopLeftCell, plage) Is Nothing Then
        s.Delete
     End If
     On Error GoTo 0
   Next s
'Copie des images
  If Not IsError(Application.Match(t, Feuil21.Columns(1), 0)) Then
    j = Application.Match(t, Feuil21.Columns(1), 0)
    For c = 3 To 15
     Feuil21.Cells(j, c).Copy Cells(i, c)
    Next
  End If
End If
Application.ScreenUpdating = -1: Application.EnableEvents = -1
End Sub

Mais plusieurs problèmes se posent que je ne comprend pas :
- Lorsque la macro est lancée, on perd la validation des données des colonnes A et B.
- les images sont bien copiées mais leur hauteur est aléatoire, un coup c'est bon, après ça réduit à 2 mm de hauteur ou encore à la moitié de la hauteur normal.

Si quelqu'un peut y regarder, car là ça me gave 😡

A+

Martial
 
Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Bonjour à tous,

Yaloo dans ton code :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim plage As Range, s As Object
Dim i&, t$
Application.ScreenUpdating = 0: Application.EnableEvents = 0
If Target.Column = 1 And Target.Row > 4 And Target.Count = 1 Then
  t = Target: i = Target.Row
'Suppression des images de la ligne modifiée
  For Each s In ActiveSheet.Shapes
    Set plage = Range(Cells(i, 3), Cells(i, 15))
    On Error Resume Next
    If s.Type = msoPicture Then
     If Not Intersect(s.TopLeftCell, plage) Is Nothing Then
        s.Delete
     End If
     End If
     On Error GoTo 0
   Next s
'Copie des images
 If Not IsError(Application.Match(t, Feuil21.Columns(1), 0)) Then
    j = Application.Match(t, Feuil21.Columns(1), 0)
    For c = 3 To 15
     Feuil21.Cells(j, c).Copy Cells(i, c)
    Next
  End If
End If
Application.ScreenUpdating = -1: Application.EnableEvents = -1
End Sub

J'ai ajouté :
Code: 
If s.Type = msoPicture Then

Dis moi ce que tu en pense !

bonne journée
 
Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Voici la macro définitive après essai

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim plage As Range, s As Object
Dim i&, t$
Application.ScreenUpdating = 0: Application.EnableEvents = 0
If Target.Column = 1 And Target.Row > 4 And Target.Count = 1 Then
  t = Target: i = Target.Row
'Suppression des images de la ligne modifiée
  For Each s In ActiveSheet.Shapes
    Set plage = Range(Cells(i, 3), Cells(i, 15))
    On Error Resume Next
    If s.Type = msoPicture Then
     If Not Intersect(s.TopLeftCell, plage) Is Nothing Then
        s.Delete
     End If
     End If
     Cells(i, 11).Delete
     On Error GoTo 0
   Next s
'Copie des images
 If Not IsError(Application.Match(t, Feuil21.Columns(1), 0)) Then
    j = Application.Match(t, Feuil21.Columns(1), 0)
    For c = 2 To 15
     Feuil21.Cells(j, c).Copy Cells(i, c)
    Next
  End If
End If
Application.ScreenUpdating = -1: Application.EnableEvents = -1
End Sub

J'ai ajouté >>> Cells(i, 11).Delete

Je t'envoie le fichier qui pour moi ne pose pas de probléme !
 

Pièces jointes

Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Re,

Le Cells(i, 11).Delete supprime toute la colonne 11, je ne vois pas l'intérêt de cette ligne de code.

Avec le fichier que tu as posté ci-dessus, si tu sélectionnes le premier item "Plafond" les images sont-elles avec une dimensions normales ?

Chez moi, ça donne ça
Capture.jpg

A+
 

Pièces jointes

  • Capture.jpg
    Capture.jpg
    59.3 KB · Affichages: 175
  • Capture.jpg
    Capture.jpg
    59.3 KB · Affichages: 176
Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Yaloo à dit:
Re,

Le Cells(i, 11).Delete supprime toute la colonne 11, je ne vois pas l'intérêt de cette ligne de code.

Avec le fichier que tu as posté ci-dessus, si tu sélectionnes le premier item "Plafond" les images sont-elles avec une dimensions normales ?

A+
Cliquez pour agrandir...

J'ai mis Cells(i, 11).Delete car le chiffre 15 est une Zone de texte pas une image qui permet d'être supprimée sans agir sur la ligne entiére avec If s.Type = msoPicture Then

D'autre part dans mon fichier si je sélectionne Plafond tout ce passe normalement !

A+
 
Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Re,

Bon, j'ai modifié la macro :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim plage As Range, s As Object
Dim i&, t$
Application.ScreenUpdating = 0: Application.EnableEvents = 0
If Target.Column = 1 And Target.Row > 4 And Target.Count = 1 Then
t = Target: i = Target.Row
'Suppression des images de la ligne modifiée
  Set plage = Range(Cells(i, 3), Cells(i, 15))
  On Error Resume Next
  For Each s In ActiveSheet.Shapes
    If s.Type = 13 Or s.Type = 17 Then
     If Not Intersect(s.TopLeftCell, plage) Is Nothing Then
        s.Delete
     End If
    End If
   Next s
  On Error GoTo 0
'Copie des images
 If Not IsError(Application.Match(t, Feuil21.Columns(1), 0)) Then
    j = Application.Match(t, Feuil21.Columns(1), 0)
    For c = 2 To 15
     Feuil21.Cells(j, c).Copy Cells(i, c)
    Next
  End If
End If
Application.ScreenUpdating = -1: Application.EnableEvents = -1
End Sub

Je trouve que c'est mieux en traitant le type plutôt quand supprimant la cellule, mais chez moi, la dimension des images reste aléatoire.

On va voir ce qu'en pense Jérôme, puisque c'est son post, après tout.

A+

Martial
 
Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Bonsoir et merci beaucoup pour tout ce travail...
Effectivement, c'est génial.
Quel travail !
Merci.

Mais j'ai le même problème, les images sont de dimentions aléatoires, a savoir rétrécies.
N'y a t'il pas la possibilitée de résoudre ce petit désagrément svp?

Bonne soirée.
 
Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Bonjour à tous,

Un essai avec la macro modifiée
Private Sub Worksheet_Change(ByVal Target As Range)
Dim plage As Range, s As Object
Dim i&, t$
Application.ScreenUpdating = 0: Application.EnableEvents = 0
If Target.Column = 1 And Target.Row > 4 And Target.Count = 1 Then
t = Target: i = Target.Row
'Suppression des images de la ligne modifiée
Set plage = Range(Cells(i, 3), Cells(i, 15))
On Error Resume Next
For Each s In ActiveSheet.Shapes
If s.Type = 13 Or s.Type = 17 Then
If Not Intersect(s.TopLeftCell, plage) Is Nothing Then
s.Delete
End If
End If
Next s
On Error GoTo 0
'Copie des images
If Not IsError(Application.Match(t, Feuil21.Columns(1), 0)) Then
j = Application.Match(t, Feuil21.Columns(1), 0)
For c = 2 To 15
'Feuil21.Cells(j, c).Copy Cells(i, c)
Feuil21.Cells(j, c).Copy
Cells(i, c).Select
ActiveSheet.Pictures.Paste.Select
Next
End If
End If
Application.ScreenUpdating = -1: Application.EnableEvents = -1
End Sub
Cliquez pour agrandir...

Cela donne cela pour moi
 

Pièces jointes

  • image PDN.jpg
    image PDN.jpg
    56.9 KB · Affichages: 90
Dernière édition:
Vote positif 0 Vote négatif
Re : VBA pour copier/coller une rechercheV

Bonsoir Jérôme, JBARBE,

Voici ton fichier avec une variante, mise à hauteur des images en fonction de la hauteur de la cellule.

Le tout dans le module ThisWorbook, comme ça tu as une seule macro pour toutes tes feuilles (elle ne se déclenche que si le nom de la feuille est numérique).

A+

Martial
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

C
  • Résolu(e)
XL 2019 Sélection en cascade ou Groupe
Réponses
12
Affichages
342
ciarab8442
C
F
  • Question Question
XL 2016 [VBA] Coller du texte sans formatage
Réponses
8
Affichages
195
F22Raptor
F
J
  • Question Question
Microsoft 365 Excel 365 Problème VBA
Réponses
7
Affichages
263
job75
job75
P
  • Question Question
XL 2021 Macro de découpage suivant une clé
Réponses
14
Affichages
519
job75
job75
ARaul
  • Question Question
XL 2019 Copier et coller automatiquement une nouvelle donnée par un bouton, ListView décallée à la sur la page (Multipage) et vibration du Userform
2
Réponses
16
Affichages
967
TooFatBoy
TooFatBoy
G
  • Question Question
XL 2016 filtrer, copier et coller les données avec la macro
Réponses
4
Affichages
320
job75
job75
treza88
  • Question Question
XL 2021 Copier coller qui ajoute une référence absolu Toute seule
2
Réponses
24
Affichages
1 K
TooFatBoy
TooFatBoy
L
  • Question Question
XL 2016 liste
Réponses
10
Affichages
386
chris
chris
M
  • Résolu(e)
XL 2021 Fonction pour rechercher des données, puis à reporter dans une 2ème feuille avec 1 critère
Réponses
13
Affichages
376
job75
job75
N
  • Question Question
Microsoft 365 Sélectionner cellule en fonction d'une liste déroulante
Réponses
9
Affichages
400
Dranreb
Dranreb
L
  • Résolu(e)
XL 2021 Macro - Liste déroulante
Réponses
4
Affichages
179
Piment
P
N
  • Résolu(e)
Microsoft 365 Copier une image d'une feuille de calcul vers un UserForm
Réponses
4
Affichages
191
NONO14
N
A
  • Question Question
Déplacer données en vba
Réponses
3
Affichages
560
akm
A
K
  • Résolu(e)
XL 2010 Roulement automatique
Réponses
9
Affichages
353
komarlehomard
K
L
  • Résolu(e)
Microsoft 365 RechercheV avec une condition poids
2
Réponses
16
Affichages
400
Lina
L
R
  • Question Question
XL 2021 Recherche formule pour compléter une cellule a partir des données d'une autre feuille du classeur (16/03/2026)
2
Réponses
18
Affichages
552
laurent950
laurent950
jeanmi
  • Résolu(e)
XL 2010 Création de listes déroulantes interactive
6 7 8
Réponses
113
Affichages
4 K
job75
job75
Titof06
  • Résolu(e)
XL 2019 Problème avec Saisie Intuitive
Réponses
4
Affichages
182
Titof06
Titof06
W
  • Question Question
Autres Code VBA
Réponses
11
Affichages
469
walki
W
N
  • Résolu(e)
XL 2021 liste déroulante en cascade
Réponses
11
Affichages
636
natadom
N
Retour