XL 2013 Recherche et Copie de lignes d'un classeur vers un autre

fgdfgg · 20 Janvier 2020

Bonjour,

je cherche à créer une petite macro me permettant de copier automatiquement la ligne du classeur Dico dont une case contient une référence qui se trouve dans une cellule d'un classeur Ref,
-la référence cherchée n'existe pas forcément dans le classeur Dico dans ce cas on passe à la valeur suivante du classeur Ref.
-Si on trouve la valeur on copie la ligne du classeur Dico puis on la colle sur la ligne du classeur Ref et on colorie le fond en rouge puis on recherche la ligne suivante...

NB:
-Les valeurs à chercher et la zone de recherche sont dans les colonne C de chaque classeur.
-Les données des tableaux commencent en ligne 13
-Il y a environ 250 lignes max par classeur
-Il n'y a (normalement) qu'une ligne max de "Dico" à copier par référence de "Ref"

Voici le code auquel je suis parvenu pour l'instant (adapté au fichier exemples joints)

VB:

Option Explicit
Sub retrouverref()
'
' retrouverref Macro
'
' Touche de raccourci du clavier: Ctrl+d
'
Application.ScreenUpdating = False
'Declaration variable
Dim Adresse As Range
Dim PlageDeRecherche As Range
Dim Valeur_Cherchee As String
Dim i As Integer

'Affectation des variable
Set PlageDeRecherche = Workbooks("Dico.xlsm").Sheets("Feuil1").Columns(3)

Set Valeur_Cherchee = Workbooks("Ref.xlsm").Sheets("Feuil1").Cells(i, 3)

'
For i = 13 To i = 250
    'Recherche
    Set Adresse = PlageDeRecherche.Cells.Find(What:=Valeur_Cherchee, LookAt:=xlPart)
    If Adresse Is Nothing Then
    Else
        'Copie
        Workbooks("Dico.xlsm").Sheets("Feuil1").Rows("Adresse.Row:Adresse.Row").Copy
        'Selection ligne de reception
        Workbooks("Ref.xlsm").Sheets("Feuil1").Rows("i:i").Select
        'Collage
        Selection.Paste
        'coloriage
        Selection.Interior.ColorIndex = 3
    End If
Next

Application.ScreenUpdating = True

End Sub

J'obtiens une erreur "Objet requis" sur la ligne d'affectation de la "Valeur_Cherchee"

J'espère avoir été clair,

Merci d'avance

sylvanu · 21 Janvier 2020

1- Comme vous faites un copier coller, et que dans la ligne copiée il y a un nom AClass déclaré, lorsque vous collez une fois il colle aussi le nom, mais la seconde fois il vous dit que ce nom AClass existe déjà.
On peut peut être faire un coller valeur. Essayez de remplacer :

Code:

Workbooks("Ref.xlsm").Sheets("Feuil1").Rows(i & ":" & i).Select
'Collage
ActiveSheet.Paste

par

Code:

Workbooks("Ref.xlsm").Sheets("Feuil1").Rows(i & ":" & i).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

2- Pas bien compris la question du nettoyage.
Remplacer
Dim Adresse As Range, Valeur,c par Dim c as String ( ou Range, à essayer )

sylvanu · 20 Janvier 2020

Bonsoir Fgdfgg,
Sauf erreur de ma part, la variable i n'est pas initialisée dans la ligne :

VB:

Set Valeur_Cherchee = Workbooks("Ref.xlsm").Sheets("Feuil1").Cells(i, 3)

De plus Erreur sur le For :

VB:

For i = 13 To 250  et non  For i = 13 To i=250

fgdfgg · 20 Janvier 2020

Bonsoir Sylvanu,

Merci pour cette réponse, effectivement j'ai probablement fait des erreurs bêtes comme le bon gros débutant (eh oui! ça se voit à peine je sais ) que je suis.

J'ai corrigé le programme en suivant tes commentaires (j'espère ne pas avoir regaffé...) et voilà ce que cela donne :

VB:

Option Explicit
Sub retrouverref()
'
' retrouverref Macro
'
' Touche de raccourci du clavier: Ctrl+d
'
Application.ScreenUpdating = False
'Declaration variable
Dim Adresse As Range
Dim PlageDeRecherche As Range
Dim Valeur_Cherchee As String
Dim i As Integer

'Initialisation
i = 13

'Affectation des variable
Set PlageDeRecherche = Workbooks("Dico.xlsm").Sheets("Feuil1").Columns(3)

Set Valeur_Cherchee = Workbooks("Ref.xlsm").Sheets("Feuil1").Cells(i, 3)


For i = 13 To 250
    'Recherche
    Set Adresse = PlageDeRecherche.Cells.Find(What:=Valeur_Cherchee, LookAt:=xlPart)
    If Adresse Is Nothing Then
    Else
        'Copie
        Workbooks("Dico.xlsm").Sheets("Feuil1").Rows("Adresse.Row:Adresse.Row").Copy
        'Selection ligne de reception
        Workbooks("Ref.xlsm").Sheets("Feuil1").Rows("i:i").Select
        'Collage
        Selection.Paste
        'coloriage
        Selection.Interior.ColorIndex = 3
    End If
Next

Application.ScreenUpdating = True

End Sub

Honnêtement je pensais que le For suffisait à initialiser mais vu qu'il est après le

Code:

Set Valeur_Cherchee = Workbooks("Ref.xlsm").Sheets("Feuil1").Cells(i, 3)

Je suppose que c'est logique.

Mon principal problème n'est cependant pas résolu, et le code affiche toujours la même erreur :

pour la même ligne (que j'ai remise ci-dessus).

J'ai passé pas mal d'heures sûr ces quelques lignes et je ne comprends pas comment me sortir de cette impasse ou comment appliquer ce que j'ai trouvé sur d'autres forums et je n'ai pas su tester.

Si vous avez une autre démarche pour arriver au même résultat je veux bien essayer.

Merci d'avance bis

sylvanu · 20 Janvier 2020

Juste un essai. Mais je ne garantis pas le résultat. Saufque ça ne plante pas.
A vous de débogguer. Je ne suis même pas sur de ce qu'il faut faire.
Bon courage.

Code:

Sub retrouverref()
Application.ScreenUpdating = False
'Declaration variable
Dim Adresse As Range, Valeur,c
Dim PlageDeRecherche As Range
Dim Valeur_Cherchee As String
Dim i As Integer
'Affectation des variable
Set PlageDeRecherche = Workbooks("Dico.xlsm").Sheets("Feuil1").Columns(3)
For i = 13 To 250
    'Recherche
    Workbooks("Ref.xlsm").Activate
    Valeur_Cherchee = Sheets("Feuil1").Cells(i + 1, 3)
    Workbooks("Dico.xlsm").Activate
    With PlageDeRecherche
        Set c = .Find(Valeur_Cherchee, LookIn:=xlValues)
        If Not c Is Nothing Then
            Ligne = c.Row
        Else
            GoTo NextOne
        End If
    End With
    ' Ligne contient la ligne où se trouve la valeur
        'Copie
        Workbooks("Dico.xlsm").Activate
        Workbooks("Dico.xlsm").Sheets("Feuil1").Rows(Ligne & ":" & Ligne).Copy
        'Selection ligne de reception
        Workbooks("Ref.xlsm").Activate
        Workbooks("Ref.xlsm").Sheets("Feuil1").Rows(i & ":" & i).Select
        'Collage
         ActiveSheet.Paste
        'coloriage
        Selection.Interior.ColorIndex = 3
NextOne:
Next
Application.ScreenUpdating = True
End Sub

fgdfgg · 21 Janvier 2020

Bonjour,

Merci beaucoup Sylvanu,

Ta solution fonctionne à une déclaration de variable près et un "+1" que je n'ai pas compris, ici, en fin de ligne:

Code:

Valeur_Cherchee = Sheets("Feuil1").Cells(i + 1, 3)

Je ne sais pas si c'est le plus approprié mais j'ai déclaré "Ligne" comme ceci:

VB:

Dim Ligne As Variant

Il a fallu entre 1 et 2 minutes pour 250 lignes.

Je ne comprend pas non plus comment fonctionne et/ou ce que signifie/comment lire :

Code:

Dim Adresse As Range, Valeur, c

Serait-il possible d'avoir une petite explication avant de clôturer le sujet?

Je vais aussi tester cela sur mon fichier original pour voir si j'ai d'autres soucis.

Encore merci

sylvanu · 21 Janvier 2020

Bonjour,
Le (i+1) était plutôt un essai pour voir. A un moment de la mise au point, j'écrivais toujours sur la même ligne.
"Adresse" et "valeur" ne servent à rien, je les utilisais avant de trouver la solution, dans une autre structure.
"c" est la cellule où est trouvée la valeur cherchée.
En fait j'ai livré "brut de fonderie" pour essai. Donc vous pouvez nettoyer.
Je pense qu'il y a plus simple que ces multiples Activate, mais je n'ai pas eu le temps d'approfondir.
Mais si ça marche ...

fgdfgg · 21 Janvier 2020

Bonjour,

Je comprends mieux, merci pour ces explications et pour votre temps.

Après essais sur mon fichier original j'obtiens le résultat souhaité à un détail près, lorsqu'une ligne est collée 2 fenêtres de ce type (voir ci-dessous) apparaissent, sauriez vous comment "cliquer" automatiquement sur "oui"?

Enfin, pour clôturer le sujet est-ce je dois mettre le code "nettoyé"/final (j'ai remis les noms originaux des classeurs...) ou votre réponse suffit-elle ?

sylvanu · 21 Janvier 2020

1- Comme vous faites un copier coller, et que dans la ligne copiée il y a un nom AClass déclaré, lorsque vous collez une fois il colle aussi le nom, mais la seconde fois il vous dit que ce nom AClass existe déjà.
On peut peut être faire un coller valeur. Essayez de remplacer :

Code:

Workbooks("Ref.xlsm").Sheets("Feuil1").Rows(i & ":" & i).Select
'Collage
ActiveSheet.Paste

par

Code:

Workbooks("Ref.xlsm").Sheets("Feuil1").Rows(i & ":" & i).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

2- Pas bien compris la question du nettoyage.
Remplacer
Dim Adresse As Range, Valeur,c par Dim c as String ( ou Range, à essayer )

fgdfgg · 21 Janvier 2020

Re,

1- J'ai trouvé la réponse tout seul (comme un grand ) en utilisant:

VB:

Application.DisplayAlerts = False

Ça fonctionne très bien (j'ai remis "True" à la fin du code )

Si j'ai un soucis j'essaierai ton collé spécial.

2- Je voulais dire remettre le code complet et fonctionnel

J'ai mis Dim c As Range et ça fonctionne

Je pense que je vais marquer ton code comme solution, encore merci Sylvanu, je t'envoie une bière par télépathie ...ggnnnnnnn nnnnn pouf.... Ah! il semble que ce soit un échec....

sylvanu · 21 Janvier 2020

Attention, ça ne fait pas la même chose.
"Application.DisplayAlerts = False" masque les alertes mais des noms seront quand même collés dans la feuille. ( De plus il masque toutes les alertes, donc éventuellement aussi les alertes qui seraient pertinentes )
Le Paste.spécial colle uniquement les valeurs sans coller les noms.
A choisir en fonction de vos besoins.

fgdfgg · 21 Janvier 2020

Je me doutais qu'il y avait un piège avec cette commande, ça aurait été trop facile sinon .
Merci pour l'info, je modifie mon code...
Ça fonctionne parfaitement (en changeant les noms des classeurs évidement).

Un grand merci pour ton aide précieuse et une bonne journée à toi et à la communauté, je repasserai peut être un de ces jours avec un nouveau casse-tête (enfin j'ai cru comprendre qu'ils ne posent pas forcément de problème à tout le monde )
A+ et merci

XL 2013 Recherche et Copie de lignes d'un classeur vers un autre

fgdfgg

XLDnaute Nouveau

Pièces jointes

sylvanu

sylvanu

XLDnaute Barbatruc

fgdfgg

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

fgdfgg

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

fgdfgg

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

fgdfgg

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

fgdfgg

XLDnaute Nouveau

Discussions similaires