XL 2016 recupere a partir d'un mot

Guismo33

XLDnaute Occasionnel
Bonjour à tous ,

une personne du forum ma gentiment fais une VBA qui fonctionne , mais je voudrais l'améliorer
voici la VBA :


Sub Copier()
Dim source As Workbook, dest As Workbook, n%
On Error Resume Next
Set source = Workbooks("Recupe_Resultat.xlsm") 'à adapter
Set dest = Workbooks("model_prono.xlsm") 'à adapter
If Err Then MsgBox "Les 2 fichiers 'Recupe' et 'model' doivent être ouverts...": Exit Sub
On Error GoTo 0
If source.Worksheets.Count <> dest.Worksheets.Count Then MsgBox "Le nombre des feuilles de calcul n'est pas le même !", 48: Exit Sub
For n = 1 To source.Worksheets.Count
source.Worksheets(n).Range("A38:D62").Copy dest.Worksheets(n).Range("AX43")
Next

End Sub

Donc je récupère les même informations sur plusieurs feuilles en A38:D62 et les copies sur un autre classeur, pour cela c bon, mon problème c que c informations que je récupère ne sont pas forcement au même endroit sur les feuilles
je vous joint une capture d'écran.
je voudrais récupère a partir du mot "Jeu Simple (1 €)" à 2 sur 4 (3 €) de toutes les feuilles .

merci à vous



bien à vous
 

Pièces jointes

  • Capture.PNG
    Capture.PNG
    26.2 KB · Affichages: 30

Guismo33

XLDnaute Occasionnel
Bonjour zebanx,

Merci beaucoup quant à moi j'ai présenté mes voeux à tout le monde en début de mois.
Bonjour job 75
oh , oui gloire ,beauté, joie et argent pour cette année 2019 .
oui c vous qui m'avais offert cette VBA et je me suis rendu compte que les fichiers importer n'était pas pas toujours
a la même cellule , donc en partant du même nom (puisque cela restera toujours le même) copier et coller.
je te remercie Job75 par avance .



bien à vous
 

Pièces jointes

  • exemple_Resultat.xlsm
    111.7 KB · Affichages: 17

Guismo33

XLDnaute Occasionnel
Bonjour job 75
oh , oui gloire ,beauté, joie et argent pour cette année 2019 .
oui c vous qui m'avais offert cette VBA et je me suis rendu compte que les fichiers importer n'était pas pas toujours
a la même cellule , donc en partant du même nom (puisque cela restera toujours le même) copier et coller.
je te remercie Job75 par avance .



bien à vous
 

Pièces jointes

  • exemple_prono.xlsm
    2.5 MB · Affichages: 9
  • exemple_prono.xlsm
    2.5 MB · Affichages: 9

job75

XLDnaute Barbatruc
Difficile à comprendre car les fichiers ne correspondent pas à la macro du post #1 :

- les noms des fichiers ne sont pas corrects

- la destination AX43 ne semble pas bonne, que faut-il utiliser ?

- pourquoi joindre 2 fichiers de 2,5 Mo ?

A+
 

Guismo33

XLDnaute Occasionnel
Difficile à comprendre car les fichiers ne correspondent pas à la macro du post #1 :

- les noms des fichiers ne sont pas corrects

- la destination AX43 ne semble pas bonne, que faut-il utiliser ?

- pourquoi joindre 2 fichiers de 2,5 Mo ?

A+
re,
oups , je me suis tromper de fichier.
 

Pièces jointes

  • exemple_prono.xlsm
    2.5 MB · Affichages: 26
  • exemple_Resultat.xlsm
    111.7 KB · Affichages: 24

job75

XLDnaute Barbatruc
Bonjour Guismo33,
pour les coller dans le fichier "exemple_prono" en AY43 .
AY43 ne me paraît pas l'endroit idéal mais bon :
Code:
Sub Copier()
Dim source As Workbook, dest As Workbook, n%, lig1 As Variant, lig2 As Variant
On Error Resume Next
Set source = Workbooks("exemple_Resultat.xlsm") 'à adapter
Set dest = Workbooks("exemple_prono.xlsm") 'à adapter
If Err Then MsgBox "Les 2 fichiers 'exemple_Resultat' et 'exemple_prono' doivent être ouverts...": Exit Sub
On Error GoTo 0
If source.Worksheets.Count <> dest.Worksheets.Count Then MsgBox "Le nombre des feuilles de calcul n'est pas le même !", 48: Exit Sub
For n = 1 To source.Worksheets.Count
    With source.Worksheets(n)
        lig1 = Application.Match("Jeu Simple (1 €)", .Columns("A"), 0)
        lig2 = Application.Match("2 sur 4 (3 €)", .Columns("A"), 0)
        dest.Worksheets(n).Range("AY43:BB" & dest.Worksheets(n).Rows.Count).Delete xlUp 'RAZ
        If IsNumeric(lig1) And IsNumeric(lig2) Then _
            .Range(.Cells(lig1, 1), .Cells(lig2, 4)).Copy dest.Worksheets(n).Range("AY43")
    End With
Next
End Sub
A+
 

Guismo33

XLDnaute Occasionnel
Bonjour Guismo33,

AY43 ne me paraît pas l'endroit idéal mais bon :
Code:
Sub Copier()
Dim source As Workbook, dest As Workbook, n%, lig1 As Variant, lig2 As Variant
On Error Resume Next
Set source = Workbooks("exemple_Resultat.xlsm") 'à adapter
Set dest = Workbooks("exemple_prono.xlsm") 'à adapter
If Err Then MsgBox "Les 2 fichiers 'exemple_Resultat' et 'exemple_prono' doivent être ouverts...": Exit Sub
On Error GoTo 0
If source.Worksheets.Count <> dest.Worksheets.Count Then MsgBox "Le nombre des feuilles de calcul n'est pas le même !", 48: Exit Sub
For n = 1 To source.Worksheets.Count
    With source.Worksheets(n)
        lig1 = Application.Match("Jeu Simple (1 €)", .Columns("A"), 0)
        lig2 = Application.Match("2 sur 4 (3 €)", .Columns("A"), 0)
        dest.Worksheets(n).Range("AY43:BB" & dest.Worksheets(n).Rows.Count).Delete xlUp 'RAZ
        If IsNumeric(lig1) And IsNumeric(lig2) Then _
            .Range(.Cells(lig1, 1), .Cells(lig2, 4)).Copy dest.Worksheets(n).Range("AY43")
    End With
Next
End Sub
A+
Re, Job

je te remercie , cela fonctionne correctement, quand ont ne connais pas grand chose c difficile par message de se faire comprendre.
je te souhaite bonne journée .

bien à vous
 

Discussions similaires

Réponses
8
Affichages
618

Statistiques des forums

Discussions
311 724
Messages
2 081 937
Membres
101 844
dernier inscrit
pktla