Regrouper les infos de plusieurs fichiers sur une feuille

WDAndCo

WDAndCo

XLDnaute Impliqué
Bonsoir le Forum

Dans ce ZIP il y a un classeur .XLS et des fichiers .CSV

Le but est de regrouper toutes les infos des fichiers.CSV sur une feuille du classeur.XLS
Une macro liste les fichiers présent dans le dossier est en place.
Et un exemple du résultat attendu est présent.

D'avance merci
 

Pièces jointes

  • Recup CSV.zip
    12.7 KB · Affichages: 32
Trier par date Trier par votes
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Regrouper les infos de plusieurs fichiers sur une feuille

Bonjour,

une premiére proposition à affiner en fonction de tes précisions.

Code: 
Sub rapatrie()
Dim Ligne As Long, Cible As Long, Fichier As String
Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")
Do Until Fichier = ""
 Workbooks.OpenText ThisWorkbook.Path & "\" & Fichier, Origin:=xlWindows, _
        StartRow:=1, DataType:=xlDelimited, Local:=True, Semicolon:=True
 With ActiveWorkbook.ActiveSheet
  Ligne = .Range("A" & .Rows.Count).End(xlUp).Row
  If ThisWorkbook.Sheets("Recap").Range("A1") <> "" Then
    Cible = ThisWorkbook.Worksheets("Recap").Range("A" & ThisWorkbook.Worksheets("Recap").Rows.Count).End(xlUp).Row + 1
   Else
    Cible = 1
  End If
  ThisWorkbook.Sheets("Recap").Range("A" & Cible & ":AC" & Ligne + Cible) = .Range("A1:AC" & Ligne).Value
  
 End With
        
 Workbooks(Fichier).Close
Fichier = Dir
Loop



End Sub
 
Vote positif 0 Vote négatif
WDAndCo

WDAndCo

XLDnaute Impliqué
Re : Regrouper les infos de plusieurs fichiers sur une feuille

Bonjour le Forum merci camarchepas

Si ca marche ! Pour la finalisalion il faudrait juste que l'export commence a partir de la ligne 11 jusqu'à la ligne avant * Fin de rapport * et cela pour chaque fichier.csv

Code: 
Sub Rapatrie()
Range("A2:AC65000").ClearContents
Dim Ligne As Long, Cible As Long, Fichier As String
Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")
Do Until Fichier = ""
 Workbooks.OpenText ThisWorkbook.Path & "\" & Fichier, Origin:=xlWindows, _
        StartRow:=1, DataType:=xlDelimited, Local:=True, Semicolon:=True
 With ActiveWorkbook.ActiveSheet
  Ligne = .Range("A" & .Rows.Count).End(xlUp).Row
  If ThisWorkbook.Sheets("Recap").Range("A2") <> "" Then
    Cible = ThisWorkbook.Worksheets("Recap").Range("A" & ThisWorkbook.Worksheets("Recap").Rows.Count).End(xlUp).Row + 1
   Else
    Cible = 2
  End If
  ThisWorkbook.Sheets("Recap").Range("A" & Cible & ":AC" & Ligne + Cible) = .Range("A1:AC" & Ligne).Value
  
 End With
        
 Workbooks(Fichier).Close
Fichier = Dir
Loop
End Sub

D'avance merci
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Regrouper les infos de plusieurs fichiers sur une feuille

Re ,

Et donc avec le découpage adoc

Code: 
Sub Rapatrie()
 Dim Ligne As Long, Cible As Long, Deb As Long, Fichier As String
 Range("A2:AC65000").ClearContents
 Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")
 Do Until Fichier = ""
  Workbooks.OpenText ThisWorkbook.Path & "\" & Fichier, Origin:=xlWindows, _
         StartRow:=1, DataType:=xlDelimited, Local:=True, Semicolon:=True
  With ActiveWorkbook.ActiveSheet
   Ligne = .Range("A" & .Rows.Count).End(xlUp).Row - 1
   If ThisWorkbook.Sheets("Recap").Range("A2") <> "" Then
     Cible = ThisWorkbook.Worksheets("Recap").Range("A" & ThisWorkbook.Worksheets("Recap").Rows.Count).End(xlUp).Row + 1
     Deb = 10
    Else
     Cible = 2
     Deb = 9
   End If
   ThisWorkbook.Sheets("Recap").Range("A" & Cible & ":AC" & Ligne + Cible - Deb) = .Range("A" & Deb & ":AC" & Ligne).Value
   
 End With
         
 Workbooks(Fichier).Close
 Fichier = Dir
 Loop
 End Sub
 
Vote positif 0 Vote négatif
WDAndCo

WDAndCo

XLDnaute Impliqué
Re : Regrouper les infos de plusieurs fichiers sur une feuille

Bonjour camarchepas et le Forum

Je reviens vers vous comme promis,
Je voudrais limiter cette importation a un certain nombre de semaine voici les noms des fichiers pour l'instant
Code: 
1501_0000023254_00001_01.csv
1502_0000023254_00001_01.csv
1503_0000023254_00001_01.csv
1504_0000023254_00001_01.csv
1505_0000023254_00001_01.csv
1506_0000023254_00001_01.csv
1507_0000023254_00001_01.csv
1508_0000023254_00001_01.csv
1509_0000023254_00001_01.csv
1510_0000023254_00001_01.csv
1511_0000023254_00001_01.csv
1512_0000023254_00001_01.csv
1513_0000023254_00001_01.csv
1514_0000023254_00001_01.csv
Le 1514 du début correspond à 2015 semaine 14 comment limiter cette extraction à S1 jusque S13 par exemple le départ seras toujours S1 dans le code qui suit :
Code: 
Sub RapatrieR()
Sheets("Recap").Visible = True
 Sheets("Recap").Select
 lg = 1
 'ligneR = .Range("A" & .Rows.Count).End(xlUp).Row
 'Range("A1") = ligneR
 Dim Ligne As Long, Cible As Long, Deb As Long, Fichier As String
 Range("A2:AC65000").ClearContents
 Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")
 Do Until Fichier = ""
  Workbooks.OpenText ThisWorkbook.Path & "\" & Fichier, Origin:=xlWindows, _
         StartRow:=1, DataType:=xlDelimited, Local:=True, Semicolon:=True
  With ActiveWorkbook.ActiveSheet
   Ligne = .Range("A" & .Rows.Count).End(xlUp).Row - 1
   If ThisWorkbook.Sheets("Recap").Range("A2") <> "" Then
     Cible = ThisWorkbook.Worksheets("Recap").Range("A" & ThisWorkbook.Worksheets("Recap").Rows.Count).End(xlUp).Row + 1
     Deb = 10
    Else
     Cible = 1
     Deb = 9
   End If
   ThisWorkbook.Sheets("Recap").Range("A" & Cible & ":AC" & Ligne + Cible - Deb) = .Range("A" & Deb & ":AC" & Ligne).Value
   
 End With
 ThisWorkbook.Sheets("Recap").Range("AN" & lg) = Fichier: lg = lg + 1: ThisWorkbook.Sheets("Recap").Range("AN" & lg) = ""
 Workbooks(Fichier).Close
 Fichier = Dir
 Loop
 Sheets("Resultats").Select
 Sheets("Recap").Select
 Sheets("Recap").Visible = False
 Sheets("Resultats").Select
 End Sub
D'avance merci
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Regrouper les infos de plusieurs fichiers sur une feuille

Bonjour ,

A voir en modifiant comme ceci

Code: 
Sub RapatrieR()
  Dim Ligne As Long, Cible As Long, Deb As Long
  Dim Fichier As String, DerniéreSem As Long
   lg = 1
   With ThisWorkbook.Sheets("Recap")
    .Visible = True
    .Range("A2:AC65000").ClearContents
   End With
    Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")
    DerniéreSem = InputBox("N° dernière semaine")
    If Not IsNumeric(DerniéreSem) Then MsgBox "Semaine non renseignée ou de façon incorrecte, sortie du traitement ": Exit Sub
    Do Until Fichier = ""
     If clng(Mid(Fichier, 3, 2)) <= DerniéreSem Then
      Workbooks.OpenText ThisWorkbook.Path & "\" & Fichier, Origin:=xlWindows, _
           StartRow:=1, DataType:=xlDelimited, Local:=True, Semicolon:=True
       With ActiveWorkbook.ActiveSheet
         Ligne = .Range("A" & .Rows.Count).End(xlUp).Row - 1
         If ThisWorkbook.Sheets("Recap").Range("A2") <> "" Then
           Cible = ThisWorkbook.Worksheets("Recap").Range("A" & ThisWorkbook.Worksheets("Recap").Rows.Count).End(xlUp).Row + 1
           Deb = 10
          Else
           Cible = 1
           Deb = 9
         End If
         ThisWorkbook.Sheets("Recap").Range("A" & Cible & ":AC" & Ligne + Cible - Deb) = .Range("A" & Deb & ":AC" & Ligne).Value
       End With
  
       ThisWorkbook.Sheets("Recap").Range("AN" & lg) = Fichier: lg = lg + 1: ThisWorkbook.Sheets("Recap").Range("AN" & lg) = ""
       Workbooks(Fichier).Close
       Fichier = Dir
     End If
    Loop

  Sheets("Recap").Visible = False
  Sheets("Resultats").Select
  End Sub
 
Vote positif 0 Vote négatif
WDAndCo

WDAndCo

XLDnaute Impliqué
Re : Regrouper les infos de plusieurs fichiers sur une feuille

Re Bonjour le Forum
Code: 
Sub RapatriePC()
  Dim Ligne As Long, Cible As Long, Deb As Long
  Dim Fichier As String, DerniéreSem As Long
   lg = 1
   With ThisWorkbook.Sheets("Recap")
    .Visible = True
    .Range("A2:AC65000").ClearContents
    .Range("AL2:AO65000").ClearContents
   End With
    Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")
    'DerniéreSem = InputBox("N° dernière semaine")
    'If Not IsNumeric(DerniéreSem) Then MsgBox "Semaine non renseignée ou de façon incorrecte, sortie du traitement ": Exit Sub
    DerniéreSem = Sheets("Entre S et S").Range("B3").Value
    Do Until Fichier = ""
     If CLng(Mid(Fichier, 3, 2)) <= DerniéreSem Then
      Workbooks.OpenText ThisWorkbook.Path & "\" & Fichier, Origin:=xlWindows, _
           StartRow:=1, DataType:=xlDelimited, Local:=True, Semicolon:=True
       With ActiveWorkbook.ActiveSheet
         Ligne = .Range("A" & .Rows.Count).End(xlUp).Row - 1
         If ThisWorkbook.Sheets("Recap").Range("A2") <> "" Then
           Cible = ThisWorkbook.Worksheets("Recap").Range("A" & ThisWorkbook.Worksheets("Recap").Rows.Count).End(xlUp).Row + 1
           Deb = 10
          Else
           Cible = 1
           Deb = 9
         End If
         ThisWorkbook.Sheets("Recap").Range("A" & Cible & ":AC" & Ligne + Cible - Deb) = .Range("A" & Deb & ":AC" & Ligne).Value
       End With
  
       ThisWorkbook.Sheets("Recap").Range("AN" & lg) = Fichier: lg = lg + 1: ThisWorkbook.Sheets("Recap").Range("AN" & lg) = ""
       Workbooks(Fichier).Close
       Fichier = Dir
     End If
    Loop

  Sheets("Recap").Visible = False
  Sheets("Entre S et S").Select
  End Sub
Ce code boucle sur le "End If" avant le "Loop"
D'avance merci
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Regrouper les infos de plusieurs fichiers sur une feuille

Ok ,

je crois avoir vu , le fichier = dir est à placer aprés le end if , comme ci dessous

Code: 
Sub RapatriePC()
   Dim Ligne As Long, Cible As Long, Deb As Long
   Dim Fichier As String, DerniéreSem As Long
    lg = 1
    With ThisWorkbook.Sheets("Recap")
     .Visible = True
     .Range("A2:AC65000").ClearContents
     .Range("AL2:AO65000").ClearContents
    End With
     Fichier = Dir(ThisWorkbook.Path & "\" & "*.csv")
     'DerniéreSem = InputBox("N° dernière semaine")
     'If Not IsNumeric(DerniéreSem) Then MsgBox "Semaine non renseignée ou de façon incorrecte, sortie du traitement ": Exit Sub
     DerniéreSem = Sheets("Entre S et S").Range("B3").Value
     Do Until Fichier = ""
      If CLng(Mid(Fichier, 3, 2)) <= DerniéreSem Then
       Workbooks.OpenText ThisWorkbook.Path & "\" & Fichier, Origin:=xlWindows, _
            StartRow:=1, DataType:=xlDelimited, Local:=True, Semicolon:=True
        With ActiveWorkbook.ActiveSheet
          Ligne = .Range("A" & .Rows.Count).End(xlUp).Row - 1
          If ThisWorkbook.Sheets("Recap").Range("A2") <> "" Then
            Cible = ThisWorkbook.Worksheets("Recap").Range("A" & ThisWorkbook.Worksheets("Recap").Rows.Count).End(xlUp).Row + 1
            Deb = 10
           Else
            Cible = 1
            Deb = 9
          End If
          ThisWorkbook.Sheets("Recap").Range("A" & Cible & ":AC" & Ligne + Cible - Deb) = .Range("A" & Deb & ":AC" & Ligne).Value
        End With
   
       ThisWorkbook.Sheets("Recap").Range("AN" & lg) = Fichier: lg = lg + 1: ThisWorkbook.Sheets("Recap").Range("AN" & lg) = ""
        Workbooks(Fichier).Close
       End If    
     Fichier = Dir
     Loop
 
  Sheets("Recap").Visible = False
   Sheets("Entre S et S").Select
   End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

L
  • Question
Microsoft 365 Effectué une recherche dans plusieurs fichiers
2 3
Réponses
31
Affichages
2 K
largo41270
L
vgendron
  • Question
Power Query [Resolu] Importer plusieurs fichiers excel provenant de dossiers différents sur sharepoint
Réponses
6
Affichages
440
Staple1600
Staple1600
B
  • Question
XL 2019 Création d'une base de données à partir de plusieurs fichiers Excel
Réponses
5
Affichages
974
battijo
B
C
  • Question
Microsoft 365 Extraction de datas dans des fichiers pdf
Réponses
2
Affichages
272
kiki29
kiki29
F
  • Résolu(e)
XL 2019 Plusieurs lignes avec mêmes donnés
2
Réponses
23
Affichages
358
DJunqueira
D
cathodique
  • Résolu(e)
XL 2010 Problème màj feuilles depuis fichiers CSV
2
Réponses
21
Affichages
953
cathodique
cathodique
R
  • Question
Microsoft 365 Formule INDIRECT avec nom du classeur variable
Réponses
4
Affichages
269
job75
job75
C
  • Résolu(e)
XL 2013 VBA - Afficher les propriété d'une liste de fichiers
Réponses
10
Affichages
335
Chrystel01
C
V
  • Question
Microsoft 365 Resume de plusieurs fichier
Réponses
2
Affichages
184
Cousinhub
Cousinhub
Usine à gaz
  • Résolu(e)
XL 2021 Rechercher dans plusieurs fichiers
2
Réponses
18
Affichages
883
Usine à gaz
Usine à gaz

Membres actuellement en ligne

4 membres et 81 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 559
Messages
2 089 603
Membres
104 224
dernier inscrit
Brilma