Regroupement de données

Bonjour,

je voudrais trouver un moyen de regrouper des données dans un seul et même fichier, avec une macro qui actualise et incrémente le jour quand le fichier se lance ( ou par l’intermédiaire d'un bouton par exemple).

les fichiers dans lequel je veux venir piocher les données, sont des rapports quotidiens avec plusieurs onglets (1 onglet par jour pour un total de 30 à 31 jours selon le mois), sachant que les rapports quotidiens du mois m-1 changeront de destination une fois le mois passé, il sera archivé mais je veux quand même garder ces valeurs dans mon fichier synthèse.

les fichiers se situent sur un réseau commun de même pour le fichier synthèse.

Avez-vous des suggestions à me faire ? Je joins un fichier que j'ai épuré pour qu'il soit moins lourd afin de vous donner une idée.

merci!

Bonjour,

as-tu un exemple de fichier source ?

on peut repartir de

• soit https://www.excel-pratique.com/fr/telechargements/utilitaires/collecter-donnees-fiches-individuelles-no478 si ls données sont dispersées dans l'onglet
• soit https://www.excel-pratique.com/fr/telechargements/utilitaires/dispatcher-compiler-excel-no466 si les données sont en tableau

Re-

Malheureusement, il me semble que ce n'est pas un exemple du fichier source, mais le même que posté en début de conversation.

Oups autant pour moi j'ai mélanger les 2 fichiers.

Pour bien comprendre, il n'y a donc qu'un seul fichier par mois avec des onglets multiples.

Je vais commencer par faire quelque chose de simple et paramétré avec un seul fichier source ... il suffira alors ensuite de faire une boucle si plusieurs fichiers.

C'est exactement ça, un seul fichier par mois avec des onglets multiples qui sont remplis au fur et à mesure, les fichiers des mois précédents sont archivés .

Oui je suppose qu'une fois le code créer un suffit de faire une boucle de plus pour chaque fichier qui s'ajoute.

Désolé, je n'ai pas pu m'y consacrer, mais je prends le sujet maintenant et cette nuit (pour la réflexion) !

Pas de soucis, je cherche aussi de mon coté et dans les lien que tu as mis plus haut.

Bonjour,

J'avoue que je n'ai pas détaillé tout ton fichier qui était assez dense. Je suis reparti d'une feuille blanche et du coup c'est moi qui vais te mettre en difficulté.

Voici un premier jet

Option Explicit
    ' Mike STEELSON
    Dim onglet As String, nomfic As String, nbcarnomfic As Integer, data As ListObject
    Dim col As Integer, nbColonnes As Integer
    Dim cel As Range, debut As Range

Sub Lecture()
Dim repertoire As String

With Sheets("parametres")

If .Range("debut").Value = "" Then
    MsgBox "Aucune donnée à relever !"
    Exit Sub
End If
If Range("repertoire").Value = "" Then
    MsgBox "Choisir un répertoire !"
    Exit Sub
End If

    ' activation de la feuille de données
    Sheets("data").Select
    Set data = ActiveSheet.ListObjects(1)
    If Not data.DataBodyRange Is Nothing Then data.DataBodyRange.Delete

    ' nbre de colonnes et mise en place des en-tetes de colonnes
    nbColonnes = 0
    For Each cel In .Range("debut:" & Range("debut").End(xlToRight).Address)
        data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = cel.Value
        nbColonnes = nbColonnes + 1
    Next cel
    'data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = "Fichier source"

    ' lecture du répertoire
    ListeFichiers .Range("repertoire").Value

    ' fin du programme
    Application.CutCopyMode = False

    MsgBox "Compilation des données terminée ! " & data.ListRows.Count & " lignes récupérées"

    ' enchainement sur programme spécifique si besoin

End With

End Sub

Sub ListeFichiers(repertoire As String)
Dim Fso, SourceFolder, SubFolder, fichier As Object, wb As Workbook, ws As Worksheet
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(repertoire)

With Sheets("parametres")

    Sheets("data").Select

    ' boucle sur tous les fichiers du répertoire
    For Each fichier In SourceFolder.Files
        If Right(fichier.Name, 4) = ".xls" Or Right(fichier.Name, 5) = ".xlsx" Or Right(fichier.Name, 5) = ".xlsm" Then
            If Left(fichier.Name, 2) <> "~$" And fichier.Name Like "*" & nomfic & "*" Then

                '... debut acces fichier
                Set wb = Workbooks.Open(Filename:=repertoire & "\" & fichier.Name)

                For Each ws In wb.Worksheets
                    For Each debut In .Range(.Range("debut").Offset(1, 0).Address & ":" & .Range("debut").End(xlDown).Address)
                        data.ListRows.Add
                        col = 1
                        For Each cel In .Range(debut.Address & ":" & .Range(debut.Address).Offset(0, nbColonnes - 1).Address)
                            If cel.Value <> "" And ws.Name Like .Range("debut").Offset(-1, col - 1) Then
                                data.DataBodyRange.Cells(data.ListRows.Count, col) = ws.Range(cel.Value)
                            End If
                            col = col + 1
                        Next cel
                        'data.DataBodyRange.Cells(data.ListRows.Count, col) = "vers ... " & fichier.Name
                        'ActiveSheet.Hyperlinks.Add Anchor:=data.DataBodyRange.Cells(data.ListRows.Count, col), Address:=fichier.ParentFolder & "\" & fichier.Name
                    Next debut

                Next ws

                Workbooks(fichier.Name).Close SaveChanges:=False
                '... fin acces fichier

            End If
        End If
    Next fichier

    ' appel récursif pour les sous-répertoires
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End With

End Sub

Sub select_repertoire()
    Dim repertoire As FileDialog
    Set repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    repertoire.Show
    If repertoire.SelectedItems.Count > 0 Then
        Range("repertoire").Value = repertoire.SelectedItems(1)
    End If
End Sub

Les fichiers source sont tous regroupés dans un même répertoire.

Les données à récupérer sont identifiées par

• le nom de l'onglet, dans l'exemple ici, quand j'ai mis [0-9]* c'est pour signifier que le nom doit commencer par un chiffre
• un titre (sans lien avec le fichier source)
• l'adresse de la donnée dans l'onglet

Exemple complet et simplifié :

bonjour,

merci bien pour ce que tu as fait sur ton premier jet, je vais le tester et essayer de voir si j'ai bien tout compris je te tiens informé merci encore !

Pour le premier point, je suis surpris, à moins que tu n'aies déplacé la cellule qui porte le nom "Debut" ! Ce point du reste m’enquiquine et donc je vais le charger ... mais j'aimerais comprendre ! Sinon, les colonnes Année et Mois qui n'ont pas d'adresse de récupération ont des formules dans le tableau, ce qu'il faut remettre à jour si on les déplace.

Pour le deuxième, comme j'ai récupérer une ancienne application, j'ai laissé cette seconde, voire troisième ligne ... la donnée se mettra sur une nouvelle ligne. Mais je ne sais pas si c'est utile ! C'est plus confus qu'utile (même si j'avais rencontré le cas un jour).

Pour le troisième, j'ai déjà solutionné (mais sans poster ... je vais le faire avec les autres corrections). Cela correspond aux onglets où rien n'est à reprendre.

Pour le dernier, je vais réinjecter un paramètre qui demande si l'on veut ajouter des données ou tout effacer avant de recompiler.

Si tu pouvais m répondre aux points 1 (regarde où se trouve la cellule "Debut") et sur l'intérêt du point 2 que je verrais bien supprimé !

Merci beaucoup pour ces remarques.

Oui pour le premier point c'est effectivement çà j'ai déplacé la cellule débute du coup je suppose que je peux changer l'ordre tant que je renomme la même cellule "début".

Pour le deuxième point oui ça ne me sera pas utile dans ce cas précis.

Pour le troisième point oui ça m'aiderait beaucoup et ça sera plus facile quand je voudrais récupéré les données.

Pour le dernier point très bonne idée ça permettrait d'injecter sans recompiler à chaque fois.

Parfait, je supprime le nom debut et je modifie demain matin les autres points

Super ! merci encore

En ce qui concerne les répertoires, l'appel est récursif sur tous les sous-répertoires du répertoire principal déclaré.

Option Explicit
    ' Mike STEELSON
    Dim data As ListObject
    Dim col As Integer, nbColonnes As Integer
    Dim cel As Range, flag As Boolean

Sub Lecture()
Dim repertoire As String

With Sheets("parametres")

If .Range("B10").Value = "" Then
    MsgBox "Aucune donnée à relever !"
    Exit Sub
End If
If Range("repertoire").Value = "" Then
    MsgBox "Choisir un répertoire !"
    Exit Sub
End If

    ' activation de la feuille de données
    Sheets("data").Select
    Set data = ActiveSheet.ListObjects(1)
    If Not data.DataBodyRange Is Nothing Then
        If MsgBox("Voulez-vous supprimer le contenu actuel ?", vbYesNo, "Demande de confirmation") = vbYes Then
            data.DataBodyRange.Delete
        End If
    End If

    ' nbre de colonnes et mise en place des en-tetes de colonnes
    nbColonnes = 0
    For Each cel In .Range("B10:" & Range("B10").End(xlToRight).Address)
        data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = cel.Value
        nbColonnes = nbColonnes + 1
    Next cel

    ' lecture du répertoire
    ListeFichiers .Range("repertoire").Value

    ' fin du programme
    Application.CutCopyMode = False

    MsgBox "Compilation des données terminée ! " & data.ListRows.Count & " lignes récupérées"

    ' enchainement sur programme spécifique si besoin

End With

End Sub

Sub ListeFichiers(repertoire As String)
Dim Fso, SourceFolder, SubFolder, fichier As Object, wb As Workbook, ws As Worksheet
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(repertoire)

With Sheets("parametres")

    Sheets("data").Select

    ' boucle sur tous les fichiers du répertoire
    For Each fichier In SourceFolder.Files
        If Right(fichier.Name, 4) = ".xls" Or Right(fichier.Name, 5) = ".xlsx" Or Right(fichier.Name, 5) = ".xlsm" Then

                '... debut acces fichier
                Set wb = Workbooks.Open(Filename:=repertoire & "\" & fichier.Name)

                For Each ws In wb.Worksheets
                    flag = True
                    col = 1
                    For Each cel In .Range("B10:" & Range("B10").End(xlToRight).Address)
                        If cel.Offset(1, 0).Value <> "" And ws.Name Like .Range("B10").Offset(-1, col - 1) Then
                            If flag Then data.ListRows.Add: flag = False
                            data.DataBodyRange.Cells(data.ListRows.Count, col) = ws.Range(cel.Offset(1, 0).Value)
                        End If
                        col = col + 1
                    Next cel
                Next ws

                Workbooks(fichier.Name).Close SaveChanges:=False
                '... fin acces fichier

        End If
    Next fichier

    ' appel récursif pour les sous-répertoires
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End With

End Sub

Sub select_repertoire()
    Dim repertoire As FileDialog
    Set repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    repertoire.Show
    If repertoire.SelectedItems.Count > 0 Then
        Range("repertoire").Value = repertoire.SelectedItems(1)
    End If
End Sub

2 solutions "simples" :

1. supprimer les lignes en doublons après compilation
2. (ce que je suggère généralement en compilation de fichiers), mettre le fichier dans son dossier normal et en mettre une copie dans un dossier "en attente de regroupement" pour ne prendre en compte que celui-ci

Sinon, cela devient complexe en terme de macro (ma philosophie est de ne jamais dépasser une feuille A4 -voire une demi-feuille A4- !)

Sans compter que du point de vue de l'utilisateur cela deviendrait aussi complexe.

Est-ce que les solutions 1 et 2 même dégradées te satisfont ?

Oui tu as raison ça peut vite devenir compliquer et j'aime bien la solution 2, elle répond à ma problématique, dans mon cas j'ai juste 1 fichier tout les mois à mettre dans le dossier en attente de regroupements, puis une fois compiler je le supprime et ainsi de suite avec les nouveaux fichiers qui arrivent.

Par contre depuis la modification j'ai quelque peu de mal à faire fonctionner la macro, après avoir lancé la lecture et répondu oui plus rien ne se passe.

J'ai remarqué que ça me le fait quand je change l'ordre des données à récupérer, pourtant je n'ai pas touché à la cellule "début"