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