Copier / coller d'un fichier a un autre avec multi critÈres

Bonjour,

Une fois n'est pas coutume, je sèche à trouver une solution à ma problématique,

j'ai bien un code qui fonctionne, mais ne fait pas tout ce que je voudrais qu'il fasse

Je m'explique:

Il y a 2 fichiers: un fichier "source" qui vient d'un extract hebdomadaire et un fichier "stock" sur lequel je je veux récupérer unique des lignes du fichier "source" qui m’intéresse.

Les lignes qui m'intéressent sont celles qui ont le même n° d'article défini dans le fichier "stock" feuille " stock".

Le problème dans mon code, est que je n'arrive pas à choisir toute la liste d'article que je veux en critère

Je fais appel à votre bon cœur, pour m'aider à résoudre ce problème

merci

Sub Copysource()

Dim source As Workbook, stock_test1 As Workbook
Dim Rw As Range
Dim lgn As Long
Dim i As Long

'ouvrir le classeur source (en lecture seule)
Chemin = ThisWorkbook.Path

'définir le classeur destination
Set stock_test1 = ThisWorkbook
Set source = Application.Workbooks.Open("C:\********\source.xlsx")

For Each Rw In Workbooks("source.xlsx").Sheets("Feuil1").Range("A2:A200000")
    If Rw.Value = Workbooks("stock_test1.xlsm").Sheets("stock").Range("A4") Then
            Rw.EntireRow.Copy Destination:=Workbooks("stock_test1.xlsm").Sheets("extract").Range("A1")
            lgn = ligne + 1
    End If
Next Rw

'fermer le classeur source
source.Close False

 If MsgBox("Copie Finie", vbYes, "Mise à jour stock") = vbYes Then

  End If

Bonjour,

Testes ce code pour voir si il te convient (à mettre à la place du tien) les deux classeurs étant dans le même dossier :

Sub Copysource()

    Dim Source As Workbook
    Dim FeExtract As Worksheet
    Dim PlgSource As Range
    Dim PlgStock As Range
    Dim CelSource As Range
    Dim CelStock As Range
    Dim I As Long
    Dim Chemin As String
    Dim Adr As String

    Chemin = ThisWorkbook.Path

    'définir le classeur destination
    Set Source = Workbooks.Open(Chemin & "\" & "source.xlsx")
    Set FeExtract = ThisWorkbook.Worksheets("extract")

    ThisWorkbook.Activate

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With Source.Worksheets("Feuil1"): Set PlgSource = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
    With ThisWorkbook.Worksheets("stock"): Set PlgStock = .Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With

    FeExtract.Cells.Clear

    For Each CelStock In PlgStock

        Set CelSource = PlgSource.Find(CelStock, , xlValues, xlWhole)

        If Not CelSource Is Nothing Then

            Adr = CelSource.Address

            Do

                I = I + 1
                FeExtract.Range(FeExtract.Cells(I, 1), FeExtract.Cells(I, 3)).Value = CelSource.Resize(1, 3).Value

                Set CelSource = PlgSource.FindNext(CelSource)

            Loop While CelSource.Address <> Adr

        End If

    Next CelStock

    Source.Close False

    MsgBox "Import des valeurs réussie !"
    FeExtract.Activate

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Bonjour Theze,

et merci, c'est exactement ce qu'il me fallait,

je vais étudier ton code, et si je comprends pas trop, je reviens vers toi

merci encore