Consolidation de fichier Excel d'un dossier

Question

Après plusieurs jours de prise de tête je viens faire appel à des experts... Je vous expose mon problème plutôt simple à la base : Je souhaites pouvoir consolidé l'ensemble des fichiers déposé dans un dossier nommé "Etude de Rem" Chaque fichier à un nom unique (généré par une macro) qui s'appui sur le nom, le type d'etude et la date Je voudrais pouvoir récupérer certaine cellule afin d'en faire une consolidation des éléments essentiels. Par exemple récupérer, le nom, prénom, l'emploi, la société juridique, ainsi que les deux package de préconisation. Avec la consolidation j'aurai alors l'ensemble des études réalisé les unes en dessous des autres. Je me heurte à plusieurs problématique : - les fichiers sont protéger par un mot de passe unique en fonction du nom de la personne et du nombre de caractère du nom - soit j'arrive à ouvrir tous les fichiers mais impossible qu'il accepte d'executer une commande de copier/coller soit je n'arrive qu'a ouvrir le premier fichier du repertoire, il accepte de faire la copie mais il ne fait pas le collage J'ai donc deux différente macro mais aucune ne fonctionne...j'ai besoin de votre aide Voici le code que j'ai : Sub test() Dim Rep As String Dim ClasseurConsolidé As String Dim ClasseurSource As String Rep = ("C:\Users\xxxxx\Documents\Test Macro de consolidation fichier") If Rep = "" Then GoTo FIN End If ClasseurConsolidé = ActiveWorkbook.Name ClasseurSource = Dir(Rep & "\*.xlsm") 'OUVRE ET RECUPERE LES DONNEES DE CHAQUE EXTRACTION Do While ClasseurSource &lt;&gt; Empty With Workbooks.Open(Rep & "\" & ClasseurSource, UpdateLinks:=0) On Error Resume Next Application.Workbooks(ClasseurSource).Worksheets("ETUDE DE REMUNERATION").Activate Range("D14:D17").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Application.Workbooks(ClasseurConsolidé).Worksheets("Référentiel").Activate Range("A3").Select Selection.End(xlDown).Select ActiveCell.Offset(1, 0).Select ActiveSheet.Paste On Error GoTo 0 Application.CutCopyMode = False End With Loop FIN: End Sub et la version 2 Sub test2() Dim dossier As Object, Fichier As Object, Chemin As String, Lg As Integer Dim ClasseurSource As String Application.ScreenUpdating = False Application.DisplayAlerts = False Range("A2:B65536").ClearContents Chemin = ThisWorkbook.Path FName = Dir(Chemin & "\" & "*.xls") Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin) For Each Fichier In dossier.Files NomFichier = Fichier.Name If Not Fichier.Name = "referentiel Etude Rem.xlsm" Then Lg = Range("A65536").End(xlUp).Row + 1 Workbooks.Open Filename:=Chemin & "/" & NomFichier Application.Workbooks(ClasseurSource).Worksheets("ETUDE DE REMUNERATION").Activate Range("D14:D17").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy On Error Resume Next With Workbooks(NomFichier) .Sheets("ETUDE DE REMUNERATION").Range("D14:B" & Range("A65536").End(xlUp).Row - 1).Copy ThisWorkbook.Sheets("ETUDE DE REMUNERATION").Range("A" & Lg).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False .Close End With End If Next Application.DisplayAlerts = True End Sub Quelqu'un aurait-il une solution à m'apporter (si possible avec des commentaire sur le code car je ne comprend pas trop ce qu'il en retourne ici) Merci a tous ceux qui prendront le temps de se pencher sur mon problème Ps : j'ai mis en pioèce jointe le formulaire présent dans le dossier à consolidé ainsi que le fichier de conso (encore vierge) attendu...

Steelson · Answer

Regarde si cet outil peut répondre ... https://www.excel-pratique.com/fr/telechargements/utilitaires/collecter-donnees-fiches-individuelles.....

Steelson · Answer

Ah bon ! je vais regarder, il est justement fait pour cela ! et peux-tu préciser le mdp ...

Steelson · Answer

Ah bon ! je vais regarder, il est justement fait pour cela ! Pour les données essentielles, cela fonctionne parfaitement (temps de mis en œuvre = 15 mn, et quelques seconds pour récupérer) Reste le mot de passe ... il est sur le fichier ou la feuille ...

Steelson · Answer

Je suis en train de simplifier le fichier (et le code dont l'originalité était de ne pas ouvrir les fichiers source, ce qui n'est pas possible si protégé par mdp) je vais ajouter le nom de l'onglet je vais prendre en compte la formule du mdp...

Steelson · Answer

Comment je peux calculer le nb de caractères du nom ? est-ce que le nom est séparé du reste par un espace ...

Steelson · Answer

J'ai simplifié le code

Le nom est celui du fichier mis en majuscule jusqu'au premier espace trouvé (pour calcule le nb de caractères)

mdp = "Rem" & Left(UCase(fichier.Name), 1) & Len(Split(fichier.Name, " ")(0))

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

Sub Lecture()
Dim repertoire As String

With Sheets("parametres")

    If Range("repertoire").Value = "" Then
        MsgBox "Choisir un répertoire !"
        Exit Sub
    End If

    ' mise en place des paramètres du programme
    onglet = .Range("onglet").Value

    ' 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

    ' lecture du répertoire
    Application.ScreenUpdating = False
    ListeFichiers .Range("repertoire").Value
    Application.ScreenUpdating = True

    ' fin du programme
    Cells.Select
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    Cells(1, 1).Select
    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
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(repertoire)

Dim ws As Workbook, wsf As Worksheet, wd As Workbook, wdf As Worksheet, tbl As ListObject, mdp As String

With Sheets("parametres")

    Sheets("data").Select
    Set wd = ThisWorkbook
    Set wdf = ActiveSheet
    Set tbl = wdf.ListObjects(1)

    ' boucle sur tous les fichiers du répertoire
    For Each fichier In SourceFolder.Files
        If fichier.Name Like "*.xls*" Then
            tbl.ListRows.Add
            col = 0

            '... debut acces fichier source
            mdp = "Rem" & Left(UCase(fichier.Name), 1) & Len(Split(fichier.Name, " ")(0))
            Set ws = Workbooks.Open(Filename:=(repertoire & "\" & fichier.Name), Password:=mdp)
            Set wsf = ws.Sheets(onglet)

                For Each cel In Range(wd.Sheets("parametres").Range("debut"), wd.Sheets("parametres").Range("debut").End(xlToRight))
                    col = col + 1
                    wsf.Range(cel.Offset(1, 0).Value).Copy
                    wd.Activate
                    wdf.Select
                    tbl.DataBodyRange.Cells(tbl.ListRows.Count, col).PasteSpecial Paste:=xlPasteValues
                Next

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

6recuperation-donnees-de-fichiers.xlsm (32.36 Ko)

Steelson · Answer

Dans ce cas, remplace à la ligne mdp = "Rem" & Left(UCase(fichier.Name), 1) & Len(Split(fichier.Name, " ")(0)) par mdp = fichier.Name mdp = Split(mdp, "_")(2) mdp = "Rem" & Left(UCase(mdp), 1) & Len(mdp) mais j'ai un doute quand tu écris TYPE_EMPLOI_NOM_DATE_ENVOI car je m'appuie sur le _ pour décomposer ( split ) le nom de fichier, donc cela ne doit pas être ça. Peux-tu mettre un vrai nom de fichier ...

Steelson · Answer

Donc la formule doit fonctionner puisque le nom est bien encadré par le second et le troisième _ Le premier aura pour mdp RemD6 Le second RemT7...