Création base de données à partir de fichiers multiples [Résolu/Fermé]

Signaler
Messages postés
300
Date d'inscription
vendredi 15 mars 2013
Statut
Membre
Dernière intervention
31 juillet 2018
-
Messages postés
12272
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
14 mai 2020
-
Bonjour à tous,

J'ai besoin de votre aide pour regrouper les données de dizaines de fichier dans un seul.
Je m'explique, 1 fois par semaine (+/-) un nouveau fichier Excel est créé par une macro qui reprend l’intégralité des déchets évacuer sur cette semaine à partir d’un encodage manuelle.
Le nom du fichier est toujours le même : « Enlèvement [NomRepreneur] du [Date].xlsx » voici un exemple : Enlèvement IndusEnvi du 9-Dec.-15.xlsx
Tous les fichiers sont stockés dans un seul et même folder qui ne contient que ces fichiers en question  U:\Déchets\Enlèvements
Le fichier fonctionne également toujours de la même façon :
- 2 onglets : Sheet1 & Sheet2 (Seul Sheet1 nous intéresse)
- Les infos des déchets sont toujours entre A6 et I30

Mon souci est que aujourd’hui je dois faire le total des déchets évacuer sur l’année dernière, j’ai donc deux solutions :
1. Reprendre tous les fichiers 1 par 1 à la main (+/- 50 fichiers)
2. Créer une macro qui copie toutes ces données sur un nouveau fichier
Personnellement je préfère la solution numéro 2 mais j’ai besoin d’aide pour ça.

Pour résumer la macro doit récupérer la plage A6 :I30 sur le premier fichier « enlèvement » coller ces informations sur un autre fichier vierge, appelons le « Total », sur la plage A6 :I30 puis copier les informations de la plage A6 :I30 du second fichier « Enlèvement » pour revenir le coller à la suite du fichier « Total » soit de A31 à I55 puis copier les informations du 3ème fichier « enlèvement » pour les coller à la suite du fichier « Total » ect… Afin d’avoir une base de données exploitables.
BONUS : Si en plus il est possible d’ajouter dans la colonne J du fichier « Total » le nom du fichier d’origine afin de connaître le nom de mon repreneur pour obtenir des stats plus précise cela serait merveilleux mais cela n’est pas indispensable en soit.

J’espère avoir été clair tout comme j’espère qu’une âme charitable aura un peu de temps pour m’aider.
Un grand merci d’avance.
Bonne journée,
Villette.

3 réponses

Messages postés
16191
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
13 mai 2020
2 953
bonjour

voir 2 ou 3 fichiers source faciliterait le travail
pour cela
Mettre les classeurs en 1 "zip" sans données confidentielles en pièce jointe sur https://www.cjoint.com/
et coller le raccourci proposé (clic droit) dans le message de réponse

Dans l’attente



Messages postés
300
Date d'inscription
vendredi 15 mars 2013
Statut
Membre
Dernière intervention
31 juillet 2018
15
Merci d'avoir pris le temps d'essayer de m'aider.

Comme demandé, voici 3 fichiers source à titre d'exemple, désolé pour les noms je n'étais pas très inspiré. http://www.cjoint.com/c/FACooNXldJV

Malgré ce que montre le template, les matières ne dépassent jamais la ligne 30 et les lignes vides peuvent être reportées dans la base de données finale car elles ne me gênent pas.

Merci d'avance.
Messages postés
15221
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
13 mai 2020
1 290
Bonjour,

Salut michel_m

Villette54:
une facon de faire: un fichier Modele_Total qui est enregistre Total_2016 pour cette annee et sera 2017 pour l'an prochain

dossier a decompresser, adaptez le chemin

https://www.cjoint.com/c/FACoToM7ELf


code avec commentaires (ben oui, ai un peu oublie dans le fichier)
Sub recup_infos()
    Dim TInfos, derlig, Fichier, rep
    
    rep = "D:\Déchets\Enlèvements\"
    Application.ScreenUpdating = False      'fige ecran
    Set WBT = Workbooks.Open("D:\Déchets\Modele_Total.xlsx")    'ouverture model
    With WBT.Worksheets("feuil1")
        derlig = .Cells.Find("*", , , , xlByRows, xlPrevious).Row       'derniere cellule non vide feuil1
        If derlig < 6 Then derlig = 6       'pas effacer entete si vide
        .Range("A6:J" & derlig).ClearContents       'efface derniere recup
    End With
    Fichier = Dir(rep & "Enlèvement*.xlsx")     'premier fichier
    If Fichier <> Empty Then        'fichier existe
        Do
            Workbooks.Open rep & Fichier    'ouverture fichier
            TInfos = ActiveWorkbook.Worksheets("Sheet1").Range("A6:I30").Value  'mise en memoire plage
            ActiveWorkbook.Close False      'fermeture fichier sans sauvegarde
            'edriture fichier model
            With WBT.Worksheets("feuil1")
                derlig = .Range("A" & Rows.Count).End(xlUp).Row + 1  'derniere cellule non vide +1 colonne A
                If derlig < 6 Then derlig = 6       ' si vide pour premier fichier
                .Range("A" & derlig & ":I" & derlig + 24) = TInfos      'restitution infos
                .Range("J" & derlig) = Fichier                                   'nom du fichier recupere
            End With
            Fichier = Dir       'fichier suivant
        Loop Until Fichier = Empty      'boucle jusqu'a plus de fichier
        WBT.SaveAs ("D:\Déchets\Total_" & Year(Date) & ".xlsx")     'sauvegarde avec annee en cours
        WBT.Close       'fermeture
    Else
        MsgBox "Pas de fichier dans ce repertoire: " & rep
        WBT.Close
        Exit Sub
    End If
    Application.ScreenUpdating = True
    
    MsgBox "Recuperation Ok"
End Sub
Messages postés
300
Date d'inscription
vendredi 15 mars 2013
Statut
Membre
Dernière intervention
31 juillet 2018
15
Bonjour,

Que dire à part un grand merci ?

C'est exactement ce qu'il me fallait. De plus la macro est "simple" à comprendre (les commentaires aident bien). Ce qui me permettra de la ré-utiliser en l'adaptant un peu pour d'autres usages.

Encore une fois, merci beaucoup.
Bonne journée,

Villette.
Messages postés
12272
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
14 mai 2020
2 421
Bonjour,

Une autre façon de faire, sans ouvrir les fichiers...
Source
Copier/Coller ce code dans un module d'un nouveau classeur :
Option Explicit

Sub ImporterDonnees()
Dim objShell As Object, objFolder As Object
Dim Chemin As String, fichier As String

Application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
If objFolder Is Nothing Then
   MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
   Cells.ClearContents
   Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
   fichier = Dir(Chemin & "*.xls")
   Do While Len(fichier) > 0
      If fichier <> ThisWorkbook.Name Then
         ThisWorkbook.Names.Add "Plage", RefersTo:="='" & Chemin & "[" & fichier & "]Sheet1'!$A$6:$I$30"
         With Sheets("Feuil2")
            .[A6:I30] = "=Plage"
            .[A6:I30].Copy
            Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
            Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(0, 10) = fichier
         End With
      End If
      fichier = Dir()
   Loop
   ThisWorkbook.Names("Plage").Delete
   [A1].Select
End If
End Sub

Messages postés
300
Date d'inscription
vendredi 15 mars 2013
Statut
Membre
Dernière intervention
31 juillet 2018
15
Merci pour cette seconde solution !

Je l'essayerai dès que possible. En revanche celle-ci me parait un peu plus complexe à comprendre mais cela ne m'empêchera pas d'essayer :)

Bref, un grand merci également.

Bonne journée,

Villette.
Messages postés
12272
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
14 mai 2020
2 421 >
Messages postés
300
Date d'inscription
vendredi 15 mars 2013
Statut
Membre
Dernière intervention
31 juillet 2018

Tu as toutes les explications dans le lien source.