XL 2019 Création macro regroupement fichiers

[st007]

Bonjour,
Mes recherches n'ont pas été fructueuses, et je ne parviens pas à mes fins, je n'excelle pas ...
Dans un dossier de mon ordi, se trouve un nombre indéterminé de fichiers (exemples joints) dans un dossier (D)
Avec parfois des noms très long
Je voudrais "juste"
Au départ d'un fichier vide contenant cette macro
choisir un dossier (With Application.FileDialog) un de mes dossiers (D)
nettoyer le fichier (beaucoup de lignes et colonnes inutiles)
A1:O74 pour le fichier Crâne (cerveau) Bracops.xlsx me suffisent amplement. Le nombre de lignes évolue évidemment
me le copier dans un onglet portant le nom du ficher d'origine
Au final, un fichier, avec autant d'onglets nommés comme le fichier d'origine

 

[st007]

Mes tentatives

Sub TraitementFichiersExcel()
    Dim dossier As String
    Dim fichier As String
    Dim classeur As Workbook
    Dim classeurGlobal As Workbook
    Dim feuilleGlobal As Worksheet

    ' Sélectionnez un dossier contenant les fichiers Excel à traiter
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Sélectionnez le dossier contenant les fichiers Excel à traiter"
        If .Show = -1 Then
            dossier = .SelectedItems(1)
        Else
            Exit Sub ' L'utilisateur a annulé la sélection
        End If
    End With

    ' Désactivez les mises à jour pour améliorer les performances
    Application.ScreenUpdating = False

    ' Crée un nouveau classeur pour les résultats
    Set classeurGlobal = Workbooks.Add
    Set feuilleGlobal = classeurGlobal.Sheets(1)

    ' Boucle à travers tous les fichiers du dossier
    fichier = Dir(dossier & "\*.xls*")
    Do While fichier <> ""
        ' Ouvre le fichier Excel
        Set classeur = Workbooks.Open(dossier & "\" & fichier)

        ' Supprime les lignes vides en bas de page et les colonnes vides à droite
'        Call SupprimerLignesColonnesVides(classeur.ActiveSheet)

        ' Copie les données dans le classeur de résultats
        classeur.ActiveSheet.Copy Before:=classeurGlobal.Sheets(classeurGlobal.Sheets.Count)

        ' Renomme l'onglet dans le fichier Global
        classeurGlobal.Sheets(classeurGlobal.Sheets.Count).Name = Left(fichier, InStrRev(fichier, ".") - 1)

        ' Ferme le fichier source
        classeur.Close SaveChanges:=False

        ' Passe au fichier suivant dans le dossier
        fichier = Dir
    Loop

    ' Supprime la feuille initiale du classeur Global
    Application.DisplayAlerts = False
    classeurGlobal.Sheets(1).Delete
    Application.DisplayAlerts = True

    ' Enregistre le classeur de résultats
    classeurGlobal.SaveAs dossier & "\Global.xlsx"

    ' Ferme le classeur de résultats
    classeurGlobal.Close SaveChanges:=True

    ' Réactivez les mises à jour
    Application.ScreenUpdating = True
End Sub

Sub SupprimerLignesColonnesVides(feui As Worksheet)
    ' Supprime les lignes vides en bas de page
    Dim derniereLigne As Long
    derniereLigne = feui.Cells(feui.Rows.Count, 1).End(xlUp).Row
    If derniereLigne > 1 Then
        feui.Rows(derniereLigne + 1 & ":" & feui.Rows.Count).Delete
    End If

    ' Supprime les colonnes vides à droite
    Dim derniereColonne As Long
    derniereColonne = feui.Cells(1, feui.Columns.Count).End(xlToLeft).Column
    If derniereColonne > 1 Then
        feui.Columns(derniereColonne + 1 & ":" & feui.Columns.Count).Delete
    End If
End Sub

 

[job75]

Bonjour st007, le forum,

Les 2 fichiers que vous avez joints étaient passablement vérolés :

- le tableau du bas ne s'affichait pas quand on copiait les cellules, il fallait mettre la police en Automatique

- pareil pour les bordures du tableau

- de plus le classeur était protégé.

J'ai donc reconstruit ces 2 fichiers, si vous en avez d'autres du même acabit il faudra les reprendre un par un.

La macro a été quelque peu revue :

Sub TraitementFichiersExcel()
    Dim dossier As String
    Dim fichier As String
    Dim classeur As Workbook
    Dim classeurGlobal As Workbook
    Dim feuilleGlobal As Worksheet

    ' Sélectionnez un dossier contenant les fichiers Excel à traiter
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Sélectionnez le dossier contenant les fichiers Excel à traiter"
        If .Show = 0 Then Exit Sub ' L'utilisateur a annulé la sélection
        dossier = .SelectedItems(1)
    End With

    ' Désactivez les mises à jour pour améliorer les performances
    Application.ScreenUpdating = False

    ' Crée un nouveau classeur pour les résultats
    Set classeurGlobal = Workbooks.Add
    Set feuilleGlobal = classeurGlobal.Sheets(1)

    ' Boucle à travers tous les fichiers du dossier
    fichier = Dir(dossier & "\*.xls*")
    Do While fichier <> ""
   
        If fichier <> ThisWorkbook.Name And fichier <> "Global.xlsx" Then
            ' Ouvre le fichier Excel
            Set classeur = Workbooks.Open(dossier & "\" & fichier)

            ' Supprime les lignes vides en bas de page et les colonnes vides à droite
            Call SupprimerLignesColonnesVides(classeur.ActiveSheet)

            ' Copie les données dans le classeur de résultats
            classeur.ActiveSheet.Copy After:=classeurGlobal.Sheets(classeurGlobal.Sheets.Count)
       
            ' Renomme l'onglet dans le fichier Global
            classeurGlobal.Sheets(classeurGlobal.Sheets.Count).Name = Left(fichier, InStrRev(fichier, ".") - 1)

            ' Ferme le fichier source
            classeur.Close SaveChanges:=False
        End If

        ' Passe au fichier suivant dans le dossier
        fichier = Dir
    Loop

    ' Supprime la feuille initiale du classeur Global
    Application.DisplayAlerts = False
    classeurGlobal.Sheets(1).Delete

    ' Enregistre le classeur de résultats
    classeurGlobal.SaveAs dossier & "\Global.xlsx", 51
    Application.DisplayAlerts = True

    ' Ferme le classeur de résultats
    classeurGlobal.Close SaveChanges:=True

    ' Réactivez les mises à jour
    Application.ScreenUpdating = True
End Sub

Sub SupprimerLignesColonnesVides(feui As Worksheet)
    If Application.CountA(feui.Cells) = 0 Then Exit Sub
    ' Supprime les lignes vides en bas de page
    Dim derniereLigne As Long
    derniereLigne = feui.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
    feui.Rows(derniereLigne + 1 & ":" & feui.Rows.Count).Delete

    ' Supprime les colonnes vides à droite
    Dim derniereColonne As Long
    derniereColonne = feui.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    feui.Range(feui.Columns(derniereColonne + 1), feui.Columns(feui.Columns.Count)).Delete
End Sub

L'erreur la plus grossière était Before au lieu de After.

A+

 

[st007]

Bonjour,
Ces fichier sont générés automatiquement, depuis un système sur lequel je n'aie pas la main.
Vérolé comment ?
Et oui, j'en ai beaucoup à traiter.
je dois même renommer certains fichiers avant la macro, car leur noms sont trop longs.
les fichiers me parviennent à 500 ko
rien que de supprimer les lignes vides et colonnes vides, le fichier ne pèse plus que 40 ko en général
un sacré cinéma ces fichiers.
D'où mon essai de traitement par macro

 

[job75]

Vérolé comment ?

J'ai bien expliqué que pour le tableau du bas les cellules et les bordures ne s'affichent pas quand on fait une copie.

 

[job75]

On peut quand même se contenter de traiter tels quels les fichiers du post #1.

Pour afficher le tableau du bas il suffit d'ajouter :

            ' police pour permettre l'affichage du tableau
            classeur.ActiveSheet.Cells.Font.ColorIndex = xlAutomatic

Sub TraitementFichiersExcel()
    Dim dossier As String
    Dim fichier As String
    Dim classeur As Workbook
    Dim classeurGlobal As Workbook
    Dim feuilleGlobal As Worksheet

    ' Sélectionnez un dossier contenant les fichiers Excel à traiter
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Sélectionnez le dossier contenant les fichiers Excel à traiter"
        If .Show = 0 Then Exit Sub ' L'utilisateur a annulé la sélection
        dossier = .SelectedItems(1)
    End With

    ' Désactivez les mises à jour pour améliorer les performances
    Application.ScreenUpdating = False

    ' Crée un nouveau classeur pour les résultats
    Set classeurGlobal = Workbooks.Add
    Set feuilleGlobal = classeurGlobal.Sheets(1)

    ' Boucle à travers tous les fichiers du dossier
    fichier = Dir(dossier & "\*.xls*")
    Do While fichier <> ""
    
        If fichier <> ThisWorkbook.Name And fichier <> "Global.xlsx" Then
            ' Ouvre le fichier Excel
            Set classeur = Workbooks.Open(dossier & "\" & fichier)

            ' Supprime les lignes vides en bas de page et les colonnes vides à droite
            Call SupprimerLignesColonnesVides(classeur.ActiveSheet)
            
            ' police pour permettre l'affichage du tableau
            classeur.ActiveSheet.Cells.Font.ColorIndex = xlAutomatic

            ' Copie les données dans le classeur de résultats
            classeur.ActiveSheet.Copy After:=classeurGlobal.Sheets(classeurGlobal.Sheets.Count)
        
            ' Renomme l'onglet dans le fichier Global
            classeurGlobal.Sheets(classeurGlobal.Sheets.Count).Name = Left(fichier, InStrRev(fichier, ".") - 1)

            ' Ferme le fichier source
            classeur.Close SaveChanges:=False
        End If

        ' Passe au fichier suivant dans le dossier
        fichier = Dir
    Loop

    ' Supprime la feuille initiale du classeur Global
    Application.DisplayAlerts = False
    classeurGlobal.Sheets(1).Delete

    ' Enregistre le classeur de résultats
    classeurGlobal.SaveAs dossier & "\Global.xlsx", 51
    Application.DisplayAlerts = True

    ' Ferme le classeur de résultats
    classeurGlobal.Close SaveChanges:=True

    ' Réactivez les mises à jour
    Application.ScreenUpdating = True
End Sub

Sub SupprimerLignesColonnesVides(feui As Worksheet)
    If Application.CountA(feui.Cells) = 0 Then Exit Sub
    ' Supprime les lignes vides en bas de page
    Dim derniereLigne As Long
    derniereLigne = feui.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
    feui.Rows(derniereLigne + 1 & ":" & feui.Rows.Count).Delete

    ' Supprime les colonnes vides à droite
    Dim derniereColonne As Long
    derniereColonne = feui.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    feui.Range(feui.Columns(derniereColonne + 1), feui.Columns(feui.Columns.Count)).Delete
End Sub

Mais les bordures du tableau ne s'affichent pas.

 

[st007]

D'accord, un soucis de déprotection du fichier peut-être.
Puisqu'en plus vous les voyez protégés.

 

[job75]

Bonjour st007,

D'accord, un soucis de déprotection du fichier peut-être.

Non, j'ai déprotégé les classeurs du post #1 avec le mot de passe "713", ça ne change rien.

A+

 

[st007]

Bonjour,
j'utilise une macro pour déprotéger, je ne suis qu'analyste, et dois donc traiter des fichiers tels qu'ils me sont envoyés.
Je vais creuser une autre piste que la protection. Mais la macro me convient en l'état.
Merci encore de vous être penché sur mon cas

 

[st007]

Du côté de la protection de structure ????

 

[job75]

La protection de structure c'est la protection du Classeur.

C'est elle que j'ai ôtée avec le mdp "713".

 

[st007]

çà ne change pas le monde, le plus bizarre, c'est en voulant mettre une couleur de fond en p3 (par exemple, mais hors des données), le fond des données clignote.
un filtre, un filigrane ???
Bref je ne sais pas ..