Recherche et copie d'une donnée à travers plusieurs fichiers
a
Bonjour,
Habitué de votre forum, je m'en sers pour tous vos conseils, sans pour autant n'avoir jamais eu besoin d'y écrire. Petite première donc.
Dans le problème qui suit, je me suis notamment inspiré d'un codes d'un collègue ici présent
Mon objectif :
Rechercher si plusieurs numéros de lots (inscrits dans le fichier avant de lancer la macro) sont présents dans plusieurs fichiers différents (eux même également listés dans le fichier).
Je commence par copier les données de tous les fichiers dans différentes feuilles.
Puis je recherche lot par lot dans l'ensemble des feuilles. Si la donnée est présente, j'extrait la ligne et je la colle.
Normalement, tout devrait macher, mais je bloque sur un problème sans doute tout bête : ma seconde boucle n'est pas reconnue.
"Erreur de compilation "Wend" sans "While".
Sub test()
'
Dim wbRecap As Workbook 'fichier recap
Dim wsRecap As Worksheet 'feuille où on écrit les données
Dim wbSource As Workbook 'fichier à ouvrir
Dim wsSource As Worksheet 'feuille où on cherche les données
Dim DernLign As Integer 'ligne où on écrit les données
Dim vFichiers As Variant 'noms des fichiers
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim rgRecap As Range 'plage où on copie les données
Dim NomFichier As String 'Nom du fichier excel à ouvrir
Dim AdrFichier As String 'Adrese du fichier excel à ouvrir
Dim ExtFichier As String 'Extension du fichier excel à ouvrir
Dim NumLot As String 'Numéro de lot cherche
Set wbRecap = ThisWorkbook 'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif
'Copie de tous les fichiers sources avant recherche des données
'Actions à réaliser tant que les lignes sont remplies
i = 28 'commence à la 28ième ligne
While Cells(i, 1).Value <> ""
'Récupération de l adresse du fichier avec les donnes a extraires
NomFichier = Cells(i, 1).Value
AdrFichier = Cells(i, 2).Value
ExtFichier = Cells(i, 3).Value
vFichiers = AdrFicher & NomFichier & ExtFichier
'Definition du fichier de travail
Workbooks.Open Filename:=AdrFichier & NomFichier & ExtFichier
Set wbSource = ActiveWorkbook
Set wsSource = wbSource.Worksheets(1)
Cells.Select 'sélectionner les cellules
Selection.Copy 'copier les cellules
Windows("recap.xls").Activate
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = NomFichier 'Renommage feuille de calcul
ActiveSheet.Paste 'Collage données
Application.DisplayAlerts = False 'permet de désactiver les messages d'alerte (sauvegarde excel)
wbSource.Close False 'fermer l'onglet
wsRecap.Select 'revenir sur la feuille principale
i = i + 1
Wend
Application.DisplayAlerts = True 'permet de réactiver les messages d'alerte excel
j = 2
While Cells(j, 2).Value <> ""
NumLot = Cells(j, 2).Value 'Récupération du numero de lot
k = 0
For Each ws In wbRecap.Worksheets
Set trouve = ws.Cells.Find(NumLot, LookIn:=xlValues, LookAt:=xlWhole) 'on cherche le numéro de lot
If Not trouve Is Nothing Then
pAddresse = trouve.Address
If k = 0 Then Set nwb = Workbooks.Add
Do
k = k + 1
ws.Rows(trouve.Row).Copy nwb.Sheets(1).Range("B" & i)
nwb.Sheets(1).Cells(i, "A").Value = ws.Name 'pour copier le nom de l'onglet d'ou provient cette ligne
Set trouve = ws.Cells.FindNext(trouve)
Loop While Not trouve Is Nothing And trouve.Address <> pAddresse
End If
Wend
wsRecap.Select 'revenir sur la feuille principale
End SubBonjour
Manque le next du For
a
Bonsoir,
Effectivement
J'ai mis à jour le code.
Le but étant de copier chaque ligne correspondant à la recherche sur ma feuille principale.
Il s'arrête à
ws.Rows(trouve.Row).Copy wsRecap.Range("E" & l)Je continuerai demain
Sub test()
'
Dim wbRecap As Workbook 'fichier recap
Dim wsRecap As Worksheet 'feuille où on écrit les données
Dim wbSource As Workbook 'fichier à ouvrir
Dim wsSource As Worksheet 'feuille où on cherche les données
Dim DernLign As Integer 'ligne où on écrit les données
Dim vFichiers As Variant 'noms des fichiers
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim rgRecap As Range 'plage où on copie les données
Dim NomFichier As String 'Nom du fichier excel à ouvrir
Dim AdrFichier As String 'Adrese du fichier excel à ouvrir
Dim ExtFichier As String 'Extension du fichier excel à ouvrir
Dim NumLot As String 'Numéro de lot cherche
Set wbRecap = ThisWorkbook 'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif
'Copie de tous les fichiers sources avant recherche des données
'Actions à réaliser tant que les lignes sont remplies
i = 28 'commence à la 28ième ligne
While Cells(i, 1).Value <> ""
'Récupération de l adresse du fichier avec les donnes a extraires
NomFichier = Cells(i, 1).Value
AdrFichier = Cells(i, 2).Value
ExtFichier = Cells(i, 3).Value
vFichiers = AdrFicher & NomFichier & ExtFichier
'Definition du fichier de travail
Workbooks.Open Filename:=AdrFichier & NomFichier & ExtFichier
Set wbSource = ActiveWorkbook
Set wsSource = wbSource.Worksheets(1)
Cells.Select 'sélectionner les cellules
Selection.Copy 'copier les cellules
Windows("recap.xls").Activate
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = NomFichier 'Renommage feuille de calcul
ActiveSheet.Paste 'Collage données
Application.DisplayAlerts = False 'permet de désactiver les messages d'alerte (sauvegarde excel)
wbSource.Close False 'fermer l'onglet
wsRecap.Select 'revenir sur la feuille principale
i = i + 1
Wend
Application.DisplayAlerts = True 'permet de réactiver les messages d'alerte excel
j = 4
l = 1
While Cells(j, 2).Value <> ""
NumLot = Cells(j, 2).Value 'Récupération du numero de lot
For Each ws In wbRecap.Worksheets
l = l + 1
Set trouve = ws.Cells.Find(NumLot, LookIn:=xlValues, LookAt:=xlWhole) 'on cherche le numéro de lot
If Not trouve Is Nothing Then
pAddresse = trouve.Address
Set wsRecap = wbRecap.Sheets(1)
Do
ws.Rows(trouve.Row).Copy wsRecap.Range("E" & l)
wsRecap.Range("D" & l).Value = ws.Name 'pour copier le nom de l'onglet d'ou provient cette ligne
Set trouve = ws.Cells.FindNext(trouve)
Loop While Not trouve Is Nothing And trouve.Address <> pAddresse
End If
Next
j = j + 1
Wend
wsRecap.Select 'revenir sur la feuille principale
End Suba
Bonsoir à tous,
j'ai avancé dans mon code.
Il a "presque" fonctionné une première fois, mais j'ai fait un changement entre -dont je ne me souviens plus- et il boucle maintenant à l'infini.
J'ai plusieurs questions :
- Qu'est ce qui ne fonctionne pas ? '(pourquoi ca boucle ? Qu'est ce que je ne trouve pas)
- Comment faire une recherche dans toutes les feuilles HORMIS la première ?
- Pourquoi n'ai-je que le résultat de ma recherche qui se colle, et pas toute la ligne ?
Merci beaucoup
Mon code :
Sub Recherche()
'
Dim wbRecap As Workbook 'fichier recap
Dim wsRecap As Worksheet 'feuille où on écrit les données
Dim wbSource As Workbook 'fichier à ouvrir
Dim wsSource As Worksheet 'feuille où on cherche les données
Dim DernLign As Integer 'ligne où on écrit les données
Dim vFichiers As Variant 'noms des fichiers
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim rgRecap As Range 'plage où on copie les données
Dim NomFichier As String 'Nom du fichier excel à ouvrir
Dim AdrFichier As String 'Adrese du fichier excel à ouvrir
Dim ExtFichier As String 'Extension du fichier excel à ouvrir
Dim NumLot As String 'Numéro de lot cherche
Set wbRecap = ThisWorkbook 'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1) 'on écrit dans la feuille 1 du fichier récapitulatif
'Copie de tous les fichiers sources avant recherche des données
'Actions à réaliser tant que les lignes sont remplies
i = 28 'commence à la 28ième ligne
While Cells(i, 1).Value <> ""
'Récupération de l adresse du fichier avec les donnes a extraires
NomFichier = Cells(i, 1).Value
AdrFichier = Cells(i, 2).Value
ExtFichier = Cells(i, 3).Value
vFichiers = AdrFicher & NomFichier & ExtFichier
'Definition du fichier de travail
Workbooks.Open Filename:=AdrFichier & NomFichier & ExtFichier
Set wbSource = ActiveWorkbook
Set wsSource = wbSource.Worksheets(1)
Cells.Select 'sélectionner les cellules
Selection.Copy 'copier les cellules
Windows("recap3.xlsm").Activate
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = NomFichier 'Renommage feuille de calcul
ActiveSheet.Paste 'Collage données
Application.DisplayAlerts = False 'permet de désactiver les messages d'alerte (sauvegarde excel)
wbSource.Close False 'fermer l'onglet
wsRecap.Select 'revenir sur la feuille principale
i = i + 1
Wend
Application.DisplayAlerts = True 'permet de réactiver les messages d'alerte excel
j = 4
m = 4
While Cells(j, 2).Value <> ""
NumLot = Cells(j, 2).Value 'Récupération du numero de lot
For Each ws In wbRecap.Worksheets
Set trouve = ws.Cells.Find(NumLot, LookIn:=xlValues, LookAt:=xlWhole) 'on cherche le numéro de lot
If Not trouve Is Nothing Then
pAddresse = trouve.Address
Do
ws.Rows(trouve.Row).Copy
Sheets("Recherche").Select
While Cells(m, 4).Value <> ""
m = m + 1
Wend
Cells(m, 5).Value = trouve
Cells(m, 4).Value = ws.Name 'pour copier le nom de l'onglet d'ou provient cette ligne
Set trouve = ws.Cells.FindNext(trouve)
Loop While Not trouve Is Nothing And trouve.Address <> pAddresse
j = j + 1
End If
Next
Wend
wsRecap.Select 'revenir sur la feuille principale
End Sub