XL 2019 Création macro regroupement fichiers

st007 · 12 Décembre 2023

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 · 12 Décembre 2023

Mes tentatives

VB:

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 · 13 Décembre 2023

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 :

VB:

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 · 13 Décembre 2023

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 · 13 Décembre 2023

st007 à dit:
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 · 13 Décembre 2023

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 :

VB:

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

VB:

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 · 13 Décembre 2023

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

job75 · 14 Décembre 2023

Bonjour st007,

st007 à dit:
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 · 14 Décembre 2023

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 · 14 Décembre 2023

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

job75 · 14 Décembre 2023

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

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

st007 · 14 Décembre 2023

çà 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 ..

XL 2019 Création macro regroupement fichiers

st007

XLDnaute Barbatruc

Pièces jointes

st007

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

st007

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

st007

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

st007

XLDnaute Barbatruc

st007

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

st007

XLDnaute Barbatruc

Discussions similaires

XL 2019 Création macro regroupement fichiers

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency