Extraire lig classeur contenant texte avec liste chemin&fich

Le 04/12/2015 à 10:43

Bonjour à tous,

J'ai énormément de mal à mettre au point un code d'extraction de données.

Je dispose d'un dossier avec plusieurs sous dossiers dans lesquels se trouvent des classeurs excel en nombre aléatoire.

Tous ces classeurs sont tramés de la même façon.

Un code qui me permet de lister sur la colonne "D" de la feuil1 du classeur le Chemin&fichier de tous les éléments dans lesquels je veux extraire des données

Dans le feuil2 j'essaie de mettre au point un code qui à partir de la liste des Chemins&fichiers pourrait m'extraire de chaque élément les lignes de l'onglet "MAQUETTE" dans lesquelles il y a inscrit "Sous total*".

Cependant, le nombre de lignes contenant "Sous-total" est différent dans chaque fichier, le code doit donc insérer un nombre de lignes en fonction.

Pour ce faire, je repars de ce code :

Sub recup()

Set f = ThisWorkbook.Sheets("Feuil1")
'parcourir la colonne 4 (à partir de la ligne 7, jusqu'à la dernière cellule non-vide de cette même colonne)
For lig = 7 To f.Cells(Rows.Count, 4).End(xlUp).Row
'ouvrir chaque fichier dont le chemin d'accès et le nom sont renseignés en colonne D
    Workbooks.Open Filename:=f.Cells(lig, 4)
'recopier en colonne F et G de ton fichier (celui contenant la macro), le contenu des cellules A16 et A19, d'une feuille nommée "MAQUETTE DEVIS" dans le ficher qui vient d'être ouvert
    ThisWorkbook.Sheets(2).Cells(lig, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A18]
    ThisWorkbook.Sheets(2).Cells(lig, 4) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A19]

    'ThisWorkbook.Sheets(2).Cells(lig, 3) = WorksheetFunction.VLookup(("Sous total").Value, ActiveWorkbook.Sheets("Détail*").Range("A1:J65000"), 2, False)

'refermer le fichier (celui dont le nom figure en colonne D)
    ActiveWorkbook.Close savechanges:=False
Next lig
End Sub

Merci d'avance pour votre aide

Le 04/12/2015 à 14:20

Bonjour,

à tester

Sub recup()

    Set f = ThisWorkbook.Sheets("Feuil1")
    'parcourir la colonne 4 (à partir de la ligne 7, jusqu'à la dernière cellule non-vide de cette même colonne)
    For lig = 7 To f.Cells(Rows.Count, 4).End(xlUp).Row
        'ouvrir chaque fichier dont le chemin d'accès et le nom sont renseignés en colonne D
        Workbooks.Open Filename:=f.Cells(lig, 4)
        'recopier en colonne F et G de ton fichier (celui contenant la macro), le contenu des cellules A16 et A19, d'une feuille nommée "MAQUETTE DEVIS" dans le ficher qui vient d'être ouvert
        l = l + 1
        ThisWorkbook.Sheets(2).Cells(l, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A18]
        ThisWorkbook.Sheets(2).Cells(l, 4) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A19]
        plage = ActiveWorkbook.Sheets("détail*").Columns("A:A")
        Set re = plage.Find("Sous total", lookat:=xlWhole)
        If Not re Is Nothing Then
            fr = re.Row
            Do
                l = l + 1
                ThisWorkbook.Sheets(2).Cells(l, 3) = re.Offset(, 1)
                re = plage.FindNext(re)
            Loop Until re Is Nothing Or re.Row = fr
        End If
        'ThisWorkbook.Sheets(2).Cells(lig, 3) = WorksheetFunction.VLookup(("Sous total").Value, ActiveWorkbook.Sheets("Détail*").Range("A1:J65000"), 2, False)

        'refermer le fichier (celui dont le nom figure en colonne D)
        ActiveWorkbook.Close savechanges:=False
    Next lig
End Sub
Le 04/12/2015 à 14:34
Set re = plage.Find("Sous total", lookat:=xlWhole)

erreur 424 objet requis

j'essaie avec le code Vlookup mais il marche uniquement lorsque la valeur proche n'est pas rentré et ne m'extrait donc pas les bonnes valeurs

ThisWorkbook.Sheets(2).Cells(lig, 3) = ActiveWorkbook.Sheets("détail (A) (2)").Application.WorksheetFunction.VLookup("Sous total Logistique", Range("A1:J50"), 2)
Le 04/12/2015 à 15:51

rebonjour

un nouvel essai à tester

Sub recup()

    Set f = ThisWorkbook.Sheets("Feuil1")
    'parcourir la colonne 4 (à partir de la ligne 7, jusqu'à la dernière cellule non-vide de cette même colonne)
   For lig = 7 To f.Cells(Rows.Count, 4).End(xlUp).Row
        'ouvrir chaque fichier dont le chemin d'accès et le nom sont renseignés en colonne D
       Workbooks.Open Filename:=f.Cells(lig, 4)
        'recopier en colonne F et G de ton fichier (celui contenant la macro), le contenu des cellules A16 et A19, d'une feuille nommée "MAQUETTE DEVIS" dans le ficher qui vient d'être ouvert
       l = l + 1
        ThisWorkbook.Sheets(2).Cells(l, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A18]
        ThisWorkbook.Sheets(2).Cells(l, 4) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A19]
        set plage = ActiveWorkbook.Sheets("détail*").Columns("A:A")
        Set re = plage.Find("Sous total", lookat:=xlWhole)
        If Not re Is Nothing Then
            fr = re.Row
            Do
                l = l + 1
                ThisWorkbook.Sheets(2).Cells(l, 3) = re.Offset(, 1)
                re = plage.FindNext(re)
            Loop Until re Is Nothing Or re.Row = fr
        End If
        'ThisWorkbook.Sheets(2).Cells(lig, 3) = WorksheetFunction.VLookup(("Sous total").Value, ActiveWorkbook.Sheets("Détail*").Range("A1:J65000"), 2, False)

        'refermer le fichier (celui dont le nom figure en colonne D)
       ActiveWorkbook.Close savechanges:=False
    Next lig
End Sub
Le 04/12/2015 à 20:49

Je t'apporte plus de détail,

'ces deux codes ne me servent plus
 ThisWorkbook.Sheets(2).Cells(l, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A18]
 ThisWorkbook.Sheets(2).Cells(l, 4) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A19]

("détail*").Columns("A:A")
"détail*" ' ne fonctionne pas, nom exact "détail (A) (2)"

"A:A" 'Sous total se trouve dans "B:B"

Loop Until re Is Nothing Or re.Row = fr   'le code bug erreur d’exécution 424 objet requis

'j'ai également essayé avec
ThisWorkbook.Sheets(2).Cells(lig, 3) = ActiveWorkbook.Sheets("détail (A) (2)").Application.WorksheetFunction.VLookup("Sous total", Range("A1:J50"), 8, False)

elle marche uniquement si j'enleve ,False et ne m'affiche pas la ligne contenant "Sous total"

Merci pour ton aide

Le 04/12/2015 à 23:03

bonsoir,

on va y arriver

Sub recup()

    Set f = ThisWorkbook.Sheets("Feuil1")
    'parcourir la colonne 4 (à partir de la ligne 7, jusqu'à la dernière cellule non-vide de cette même colonne)
  For lig = 7 To f.Cells(Rows.Count, 4).End(xlUp).Row
        'ouvrir chaque fichier dont le chemin d'accès et le nom sont renseignés en colonne D
      Workbooks.Open Filename:=f.Cells(lig, 4)
        'recopier en colonne F et G de ton fichier (celui contenant la macro), le contenu des cellules A16 et A19, d'une feuille nommée "MAQUETTE DEVIS" dans le ficher qui vient d'être ouvert
      l = l + 1
        ThisWorkbook.Sheets(2).Cells(l, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A18]
        ThisWorkbook.Sheets(2).Cells(l, 4) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A19]
        set plage = ActiveWorkbook.Sheets("détail (A) (2)").Columns("B:B")
        Set re = plage.Find("Sous total", lookat:=xlWhole)
        If Not re Is Nothing Then
          set  fr = re
            Do
                l = l + 1
                ThisWorkbook.Sheets(2).Cells(l, 3) = re.Offset(, 1)
                re = plage.FindNext(re)
            Loop Until re Is Nothing Or re = fr
        End If
        'ThisWorkbook.Sheets(2).Cells(lig, 3) = WorksheetFunction.VLookup(("Sous total").Value, ActiveWorkbook.Sheets("Détail*").Range("A1:J65000"), 2, False)

        'refermer le fichier (celui dont le nom figure en colonne D)
      ActiveWorkbook.Close savechanges:=False
    Next lig
End Sub
Le 05/12/2015 à 14:23

Il le faut, bonne nouvelle, la ligne du premier "Sous total*" est bien extraite.

Je me suis permis de rajouter qq commentaires pour m'éclaircir le code

Sub recupdetail()

Range("B7").Select
Range("B7:D65536").Clear

'dans la feuil1 de c classeur
Set f = ThisWorkbook.Sheets("Feuil1")
'parcourir la colonne 4 (à partir de la ligne 7, jusqu'à la dernière cellule non-vide de cette même colonne)
For lig = 7 To f.Cells(Rows.Count, 4).End(xlUp).Row
'ouvrir chaque fichier dont le chemin d'accès et le nom sont renseignés en colonne D
    Workbooks.Open Filename:=f.Cells(lig, 4), UpdateLinks:=0

l = l + 1
        ThisWorkbook.Sheets(1).Cells(l, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A16]
        'dans détail (A) (2) colone B:B
        Set plage = ActiveWorkbook.Sheets("détail (A) (2)").Columns("B:B")
        'cherche "Sous total*"
        Set re = plage.Find("Sous total*", lookat:=xlWhole)
        'si "Sous total*" trouvé alors
        If Not re Is Nothing Then

        'copier la ligne contanant "Sous total*" (colones 1 2 3 4 5 6 7 de cette ligne)
        ThisWorkbook.Sheets(2).Cells(l, 4) = re.Offset(, 1)
        ThisWorkbook.Sheets(2).Cells(l, 5) = re.Offset(, 2)
        ThisWorkbook.Sheets(2).Cells(l, 6) = re.Offset(, 3)
        ThisWorkbook.Sheets(2).Cells(l, 7) = re.Offset(, 4)
        ThisWorkbook.Sheets(2).Cells(l, 8) = re.Offset(, 5)
        ThisWorkbook.Sheets(2).Cells(l, 9) = re.Offset(, 6)
        ThisWorkbook.Sheets(2).Cells(l, 10) = re.Offset(, 7)

        Set fr = re
            Do
                l = l + 1
            re = plage.FindNext(re)
            Loop Until re Is Nothing Or re = fr
        End If

ActiveWorkbook.Close savechanges:=False
Next lig
End Sub
 Loop Until re Is Nothing Or re = fr   ' erreur 424 Objet requis

'et avec

 Loop Until fr Is Nothing Or fr = re   'erreur 1004 impossible de lire la propriete findnext dans la classe Range

On va y arriver

Le 05/12/2015 à 16:23

bonjour,

un nouvel essai, j'avais oublié une instruction set dans le findnext.

Sub recupdetail()

Range("B7").Select
Range("B7:D65536").Clear

'dans la feuil1 de c classeur
Set f = ThisWorkbook.Sheets("Feuil1")
'parcourir la colonne 4 (à partir de la ligne 7, jusqu'à la dernière cellule non-vide de cette même colonne)
For lig = 7 To f.Cells(Rows.Count, 4).End(xlUp).Row
'ouvrir chaque fichier dont le chemin d'accès et le nom sont renseignés en colonne D
   Workbooks.Open Filename:=f.Cells(lig, 4), UpdateLinks:=0
        ThisWorkbook.Sheets(1).Cells(l, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A16]
        'dans détail (A) (2) colone B:B
       Set plage = ActiveWorkbook.Sheets("détail (A) (2)").Columns("B:B")
        'cherche "Sous total*"
       Set re = plage.Find("Sous total*", lookat:=xlWhole)
        'si "Sous total*" trouvé alors
       If Not re Is Nothing Then
        Set fr = re
            Do
                l = l + 1
       'copier la ligne contenant "Sous total*" (colones 1 2 3 4 5 6 7 de cette ligne)
       ThisWorkbook.Sheets(2).Cells(l, 4) = re.Offset(, 1)
        ThisWorkbook.Sheets(2).Cells(l, 5) = re.Offset(, 2)
        ThisWorkbook.Sheets(2).Cells(l, 6) = re.Offset(, 3)
        ThisWorkbook.Sheets(2).Cells(l, 7) = re.Offset(, 4)
        ThisWorkbook.Sheets(2).Cells(l, 8) = re.Offset(, 5)
        ThisWorkbook.Sheets(2).Cells(l, 9) = re.Offset(, 6)
        ThisWorkbook.Sheets(2).Cells(l, 10) = re.Offset(, 7)
            set re = plage.FindNext(re)
            Loop Until re Is Nothing Or re = fr
        End If

ActiveWorkbook.Close savechanges:=False
Next lig
End Sub
Le 05/12/2015 à 21:56

C marche, c'est super, comment faire pour rechercher en plus du contenu "Sous total*" les cases "Total*" ?

Je pense avoir une vérole qq part, mon fichier fait maintenant 30Mo

Le 06/12/2015 à 00:06

Bonsoir,

code adapté

Sub recupdetail()

Range("B7").Select
Range("B7:D65536").Clear

'dans la feuil1 de c classeur
Set f = ThisWorkbook.Sheets("Feuil1")
'parcourir la colonne 4 (à partir de la ligne 7, jusqu'à la dernière cellule non-vide de cette même colonne)
For lig = 7 To f.Cells(Rows.Count, 4).End(xlUp).Row
'ouvrir chaque fichier dont le chemin d'accès et le nom sont renseignés en colonne D
  Workbooks.Open Filename:=f.Cells(lig, 4), UpdateLinks:=0
        ThisWorkbook.Sheets(1).Cells(l, 3) = ActiveWorkbook.Sheets("MAQUETTE DEVIS").[A16]
        'dans détail (A) (2) colone B:B
      Set plage = ActiveWorkbook.Sheets("détail (A) (2)").Columns("B:B")
        'cherche "Sous total*"
      Set re = plage.Find("total*", lookat:=xlpart,matchcase:=false)
        'si "Sous total*" trouvé alors
      If Not re Is Nothing Then
        Set fr = re
            Do
                l = l + 1
       'copier la ligne contenant "Sous total*" (colones 1 2 3 4 5 6 7 de cette ligne)
      ThisWorkbook.Sheets(2).Cells(l, 4) = re.Offset(, 1)
        ThisWorkbook.Sheets(2).Cells(l, 5) = re.Offset(, 2)
        ThisWorkbook.Sheets(2).Cells(l, 6) = re.Offset(, 3)
        ThisWorkbook.Sheets(2).Cells(l, 7) = re.Offset(, 4)
        ThisWorkbook.Sheets(2).Cells(l, 8) = re.Offset(, 5)
        ThisWorkbook.Sheets(2).Cells(l, 9) = re.Offset(, 6)
        ThisWorkbook.Sheets(2).Cells(l, 10) = re.Offset(, 7)
            set re = plage.FindNext(re)
            Loop Until re Is Nothing Or re = fr
        End If

ActiveWorkbook.Close savechanges:=False
Next lig
End Sub
Le 06/12/2015 à 20:22

Merci pour tout h2so4 au plaisir de remettre au point un code avec toi

Rechercher des sujets similaires à "extraire lig classeur contenant texte liste chemin fich"