Vba Pompages d'une ligne sur 100 ficher

Bens7 · 2 Juillet 2013

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....

Bens7 · 2 Juillet 2013

Re : Vba Pompages d'une ligne sur 100 ficher

je sais pas si j'ai etais clair : Tous les fichiers sont dans un dossier FACTURATION et le tableau a l'exterieur

bbb38 · 3 Juillet 2013

Re : Vba Pompages d'une ligne sur 100 ficher

Bonjour Bens7, le forum,
Un exemple avec des feuilles (à adapter pour les fichiers).
Cordialement,
Bernard

mapomme · 3 Juillet 2013

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

Bens7 · 3 Juillet 2013

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 !

mikachu · 3 Juillet 2013

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/

mikachu · 3 Juillet 2013

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

Bens7 · 3 Juillet 2013

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

Bens7 · 3 Juillet 2013

Re : Vba Pompages d'une ligne sur 100 ficher

Desole mikachu marche pas

Bens7 · 3 Juillet 2013

Re : Vba Pompages d'une ligne sur 100 ficher

Je vous met un exemple des dossiers

mikachu · 3 Juillet 2013

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.

Bens7 · 3 Juillet 2013

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

mikachu · 3 Juillet 2013

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.

Bens7 · 3 Juillet 2013

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 ....

mapomme · 3 Juillet 2013

Re : Vba Pompages d'une ligne sur 100 ficher

Bonsoir Bens7,

Je te l'adapte dans la soirée...🙄

Vba Pompages d'une ligne sur 100 ficher

Bens7

XLDnaute Impliqué

Bens7

XLDnaute Impliqué

bbb38

XLDnaute Accro

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

Bens7

XLDnaute Impliqué

mikachu

XLDnaute Occasionnel

mikachu

XLDnaute Occasionnel

Bens7

XLDnaute Impliqué

Bens7

XLDnaute Impliqué

Bens7

XLDnaute Impliqué

Pièces jointes

mikachu

XLDnaute Occasionnel

Bens7

XLDnaute Impliqué

mikachu

XLDnaute Occasionnel

Bens7

XLDnaute Impliqué

mapomme

XLDnaute Barbatruc

Discussions similaires

Vba Pompages d'une ligne sur 100 ficher

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

Pièces jointes

XLDnaute Occasionnel

XLDnaute Impliqué

XLDnaute Occasionnel

XLDnaute Impliqué

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency