Vba Pompages d'une ligne sur 100 ficher

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Bens7
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
B

Bens7

XLDnaute Impliqué
Bonjours a tous !!
J'ai un dossier avec 100 fichiers excel nomer ainsi : 1 ; 1 (2); 1 (3) ; 1 (4) .... 1 (100)
chaque fichier contient une seul Feuil mais qui n'a pas le meme nom dans chaque fichier

j'aimerais grace a un bouton recuperer la ligne 60 de chacun de ces fichiers et les avoir une a une dans un tableau
Merci a tous ! j'espere que c'est clair lolll....
 
Trier par date Trier par votes
Re : Vba Pompages d'une ligne sur 100 ficher

Bonjour Bens7, à tous,

Un essai dans le fichier joint.

Deux constantes à adapter à votre cas:
  • Repert : qui contient le chemin complet du répertoire des fichiers sources.
  • LigneDepart : qui est numéro de ligne à partir de laquelle on écrit les lignes récupérées.

Le code:
VB: 
Sub Recuperer60()

Const Repert = "D:\EXCEL\@EXCEL-DOWNLOADS\@TEST\Fact\Facturation"
Const LigneDepart = 2

Dim LesFichiers(), i, rep As String
Dim Fichier As String, Ligne As Long

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Lignes60").Activate

If Right(Repert, 1) <> "\" Then rep = Repert & "\" Else rep = Repert
Fichier = Dir(rep & "\" & "1.xlsx")
If Fichier <> "" Then
  ReDim LesFichiers(1 To 1)
  LesFichiers(1) = rep & Fichier
End If

Fichier = Dir(rep & "\*.*")
Do While Fichier <> ""
  If Fichier Like "* (*).xls?" Then
    ReDim Preserve LesFichiers(1 To UBound(LesFichiers) + 1)
    LesFichiers(UBound(LesFichiers)) = rep &  Fichier
  End If
  Fichier = Dir
Loop

Ligne = LigneDepart + 1
With ThisWorkbook.Sheets("Lignes60")
  .Range("A" & Ligne & ":A" & .Rows.Count).Clear
  .Range("A" & Ligne).Resize(UBound(LesFichiers)).Value = Application.Transpose(LesFichiers)
  .Range("A" & Ligne).Resize(UBound(LesFichiers)).Sort key1:=.Range("A" & Ligne), Header:=xlNo
  .Range("A" & LigneDepart).Value = .Range("A" & .Rows.Count).End(xlUp)
  .Range("A" & .Rows.Count).End(xlUp).Clear
   LesFichiers = .Range("A" & LigneDepart).Resize(UBound(LesFichiers)).Value
  .Range("A" & Ligne & ":A" & .Rows.Count).Clear
End With

Ligne = LigneDepart
For i = 1 To UBound(LesFichiers)
  Workbooks.Open LesFichiers(i, 1)
  ActiveWorkbook.ActiveSheet.Rows(60).Copy
  ThisWorkbook.Sheets("Lignes60").Rows(Ligne).PasteSpecial Paste:=xlPasteValues
  Application.DisplayAlerts = False
  ActiveWorkbook.Close Savechanges:=False
  Application.DisplayAlerts = True
  Ligne = Ligne + 1
Next i

Application.CutCopyMode = False
Application.Goto Range("A" & IIf(LigneDepart = 1, 1, LigneDepart - 1)), True
Application.ScreenUpdating = True
End Sub
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

Bonjour a tous !!
Alors mapomme c'est Genial j'ai un peu modifier le code car c'etait des fichers xlsm mais bon ....
oserais je te demander la meme chose sauf que disons mes fichiers ne s'apelle pas : 1 ; 1 (2); 1 (3) ; 1 (4) .... 1 (100)
Mais des noms different pour chacun :
exemple:
toto sarl ; fabrice sa; paul sarl ect.....
(ca m'eviterais une operation de tous les renomer a chaque fois !)

Merci encore !
 
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

Bonjour,

Trouvé sur un fil du forum et légèrement adapté:

Edit: exemple pour pomper la case A60

VB: 
Option Explicit
Sub test()
Dim MonRepertoire As String, fso As Object, f As Object, i As Integer, DerLigne As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "Colle le répertoire ici"
For Each f In fso.GetFolder(MonRepertoire).Files
    If Right(f.Name, 4) = ".xlsm" Then
    Workbooks.Open MonRepertoire & f.Name
    DerLigne = ThisWorkbook.Sheets("Feuil1").Range("A65536").End(xlUp).Row + 1
    ThisWorkbook.Sheets("Feuil1").Cells(DerLigne, 1).Value = Workbooks(f.Name).Sheets("Feuil1").Range("A60").Value
    Workbooks(f.Name).Close SaveChanges:=False
    End If
Next f
End Sub

Post de base: https://www.excel-downloads.com/threads/vb-ouvrir-tous-les-fichiers-xls-dun-dossier.110292/
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

Une autre version, plus agréable car elle va chercher la valeur sans ouvrir le fichier.
VB: 
Option Explicit
Sub test()
Dim MonRepertoire As String, fso As Object, f As Object, i As Integer, DerLigne As Integer
Dim FichierAOuvrir As String

Set fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "Ton répertoire\"
For Each f In fso.GetFolder(MonRepertoire).Files
    If Right(f.Name, 4) = ".xlsm" Then
    DerLigne = ThisWorkbook.Sheets("Feuil1").Range("A65536").End(xlUp).Row + 1
    FichierAOuvrir = "'" & MonRepertoire & "[" & f.Name & "]Feuil1'!R60C1"
    ThisWorkbook.Sheets("Feuil1").Cells(DerLigne, 1).Value = ExecuteExcel4Macro(FichierAOuvrir)
    End If
Next f
End Sub
 
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

mikachu je vais essayer la derniere par contre on est bien d'accord (car je voie du Feuil1 dans le code ) chaque fichier ne contient que 1 seul Feuil mais le nom varie defois c'est Feuil6; Feuil1; Feuil24
 
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

Un peu modifié et ajouté routine pour chercher le nom de feuille de calcul.
Ca fonctionne chez moi, mis à part une boite de dialogue que je n'arrive pas à retirer

Ne fonctionnera que avec des classeurs ne contenant qu'une seule feuille

VB: 
Option Explicit
Dim NomDeRepertoire, MonFichier As String, fso As Object, f As Object, i As Integer, DerLigne As Integer
Dim FichierAOuvrir As String, NomDeFichier As String
Dim XlConnect As Object, XlCatalog As Object
Dim Fichier As String, Resultat As String
Dim Feuille As Object


Sub test2()

Set fso = CreateObject("Scripting.FileSystemObject")
NomDeRepertoire = "Ton répertoire\"
For Each f In fso.GetFolder(NomDeRepertoire).Files
    DerLigne = ThisWorkbook.Sheets("Feuil1").Range("A65536").End(xlUp).Row + 1
    If Right(f.Name, 5) = ".xlsm" Then
    NomDeFichier = f.Name
    
    ListeFeuillesClasseurFerme
    
    FichierAOuvrir = "'" & NomDeRepertoire & "[" & NomDeFichier & "]" & Resultat & "'!R60C1"
    MsgBox FichierAOuvrir
    ThisWorkbook.Sheets("Feuil1").Cells(DerLigne, 1).Value = ExecuteExcel4Macro(FichierAOuvrir)
    End If
Next f

End Sub

Sub ListeFeuillesClasseurFerme()
 
    Fichier = NomDeRepertoire & f.Name
 
    Set XlConnect = CreateObject("ADODB.Connection")
    Set XlCatalog = CreateObject("ADOX.Catalog")
 
    XlConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & _
            ";Extended Properties=Excel 8.0;"
    Set XlCatalog.ActiveConnection = XlConnect
 
    For Each Feuille In XlCatalog.Tables
        Resultat = Left(Feuille.Name, Len(Feuille.Name) - 1)
    Next

    XlConnect.Close

 
End Sub

Je ne comprend pas pourquoi cette boite de dialogue, si quelqu'un a une idée...

EDIT: modification de la macro, la boite de dialogue ne s'ouvre plus.
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

Desole mikachu mais ca marche toujours pas
bloque a :
Code: 
     XlConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & _
             ";Extended Properties=Excel 8.0;"

pet tu me l'adapter directement sur le ZIP Post #10 que je puisse comprendre
Merci
 
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

En effet, sous xl 2007 et 2010, la synthaxe est différente.

essaye en remplaçant

VB: 
    XlConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fichier & _
            ";Extended Properties=Excel 8.0;"

Par:
VB: 
    With XlConnect
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
    End With

Je n'avais pas vu cette subtilité. Je suis sous XL2003.
 
Vote positif 0 Vote négatif
Re : Vba Pompages d'une ligne sur 100 ficher

Desole vraiment mais pas bon : la Text Box c'est pas possible ya 150 fichiers
et ca copie juste la collonne A
Voici le code actuel

Code: 
Option Explicit
 Dim NomDeRepertoire, MonFichier As String, fso As Object, f As Object, i As Integer, DerLigne As Integer
 Dim FichierAOuvrir As String, NomDeFichier As String
 Dim XlConnect As Object, XlCatalog As Object
 Dim Fichier As String, Resultat As String
 Dim Feuille As Object
 

Sub test()
 
Set fso = CreateObject("Scripting.FileSystemObject")
 NomDeRepertoire = "C:\Users\BEN\Desktop\FORUM\FACTURATION\FACTURATION\A FACTURER\"
 For Each f In fso.GetFolder(NomDeRepertoire).Files
     DerLigne = ThisWorkbook.Sheets("Feuil1").Range("A65536").End(xlUp).Row + 1
     If Right(f.Name, 5) = ".xlsm" Then
     NomDeFichier = f.Name
     
    ListeFeuillesClasseurFerme
     
    FichierAOuvrir = "'" & NomDeRepertoire & "[" & NomDeFichier & "]" & Resultat & "'!R60C1"
     MsgBox FichierAOuvrir
     ThisWorkbook.Sheets("Feuil1").Cells(DerLigne, 1).Value = ExecuteExcel4Macro(FichierAOuvrir)
     End If
 Next f
 
End Sub
 
Sub ListeFeuillesClasseurFerme()
  
     Fichier = NomDeRepertoire & f.Name
  
     Set XlConnect = CreateObject("ADODB.Connection")
     Set XlCatalog = CreateObject("ADOX.Catalog")
  
    With XlConnect
         .Provider = "Microsoft.Jet.OLEDB.4.0"
         .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
             & Fichier & ";Extended Properties=""Excel 12.0;HDR=YES;"""
         .Open
     End With
     Set XlCatalog.ActiveConnection = XlConnect
  
     For Each Feuille In XlCatalog.Tables
         Resultat = Left(Feuille.Name, Len(Feuille.Name) - 1)
     Next
 
    XlConnect.Close
 
 
 End Sub

la solution de Mapomme reste la plus simple mais toujours ce probleme faut renommer les fichiers ....
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

N
  • Résolu(e)
XL 2013 Somme VBA sur plusieurs ligne
Réponses
8
Affichages
319
Nico77
N
Eric 888
  • Question Question
Microsoft 365 Excel VBA: manipuler des fichiers partagés via Teams / Sharepoint
Réponses
2
Affichages
131
Eric 888
Eric 888
J
  • Question Question
XL 2016 Formule de recherche de valeurs sur deux onglets en entête et en ligne
2
Réponses
22
Affichages
682
Jaykerz
J
Y
  • Question Question
Power Query Besoin d'aide pour configurer un power query
Réponses
3
Affichages
280
alexga78
A
N
  • Question Question
XL 2010 recherche formule
2
Réponses
23
Affichages
680
n_turf
N
pascal21
  • Question Question
Microsoft 365 sélectionner la premiere ligne d'une liste filtrée par vba
Réponses
2
Affichages
225
sylvanu
sylvanu
N
  • Question Question
XL 2021 Affecter automatiquement une valeur dans une cellule en fonction d'une saisie dans une autre cellule
Réponses
9
Affichages
322
Nico Gre
N
C
  • Résolu(e)
Microsoft 365 Recherche de doublons à plusieurs critères sur plusieurs colonnes
Réponses
4
Affichages
369
job75
job75
M
  • Question Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
762
mromain
mromain
X
  • Question Question
XL 2021 Transformation de données sur une ligne en plusieurs lignes
Réponses
9
Affichages
525
xavieralvaro
X
M
  • Question Question
XL 2013 MACRO VBA pour imprimer tous les bulletins d'un établissement scolaire
Réponses
4
Affichages
808
MBEPID
M
piga25
  • Résolu(e)
XL 2016 En VBA, Automatiser la réponse en fonction de l'état d'une cellule.
Réponses
7
Affichages
878
piga25
piga25
L
  • Résolu(e)
Microsoft 365 Retourner l'en-tête colonne correspondante à une quantité donnée dans une ligne
Réponses
4
Affichages
408
LegVal
L
D
  • Résolu(e)
XL 2021 Selection listview et Envoie Emails automatique
Réponses
4
Affichages
455
delsart59
D
p'tit vieux
  • Question Question
XL 2021 FINDXTREME: Je compte sur vos avis sur ce projet … Par avance MERCI
Réponses
10
Affichages
375
p'tit vieux
p'tit vieux
I
  • Question Question
XL 2021 comptage d’une col
Réponses
3
Affichages
281
ivgu19
I
J
  • Question Question
Microsoft 365 Copie des onglets dans un fichier séparé depuis une liste en VBA
Réponses
3
Affichages
511
job75
job75
P
  • Résolu(e)
XL 2021 Requête API - VBA Excel - Parse JSON
Réponses
2
Affichages
908
picc
P
D
  • Résolu(e)
Microsoft 365 Assistance pour optimisation d'un code VBA qui ne fonctionne pas comme souhaité
2
Réponses
21
Affichages
1 K
desto
D
S
  • Résolu(e)
Microsoft 365 Ecrasement d'une ligne si déjà existante
Réponses
2
Affichages
456
sebastien176
S
Retour