XL 2019 Création macro regroupement fichiers

S

st007

XLDnaute Barbatruc
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
 

Pièces jointes

  • Crâne (cerveau) Bracops.xlsx
    41.2 KB · Affichages: 17
  • Rachis cervical.xlsx
    40.1 KB · Affichages: 13
Trier par date Trier par votes
S

st007

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Crâne (cerveau) Bracops.xlsx
    19.2 KB · Affichages: 3
  • Rachis cervical.xlsx
    17 KB · Affichages: 2
Dernière édition:
Vote positif 0 Vote négatif
S

st007

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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.
 
Vote positif 0 Vote négatif
S

st007

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2019 Power query - Réunir le contenu de plusieurs fichiers xls dans un seul
Réponses
10
Affichages
1 K
Bernard_XLD
Bernard_XLD
N
  • Question
XL 2016 Macro chargement liste arborescence, copier coller fichiers
Réponses
9
Affichages
386
Nermal64
N
P
  • Résolu(e)
XL 2016 4 étapes en 1 seule Excel vba
Réponses
4
Affichages
465
Pygos691
P
M
  • Question
XL 2016 Regrouper données de plusieurs fichiers dans un seul
Réponses
2
Affichages
638
MrPrepus
M
C
  • Question
XL 2019 Supprimer tous les fichiers doublons d'un dossier
Réponses
7
Affichages
558
carlos
C
Usine à gaz
  • Résolu(e)
XL 2021 Faire une copie de mon classeur quand "Target" change
2 3
Réponses
30
Affichages
2 K
Usine à gaz
Usine à gaz
Usine à gaz
  • Résolu(e)
Microsoft 365 Liaisons externes par macro
2 3
Réponses
33
Affichages
2 K
Usine à gaz
Usine à gaz
J
  • Question
Microsoft 365 Macro excel spécifier chemin de sauvegarde one drive
Réponses
4
Affichages
477
.jakob@gmail.com
J
Usine à gaz
  • Résolu(e)
Microsoft 365 lister des fichiers
2
Réponses
19
Affichages
2 K
Usine à gaz
Usine à gaz
Z
  • Résolu(e)
Microsoft 365 Modification du plusieurs fichiers excel en une seule fois
Réponses
3
Affichages
728
Zifox
Z

Membres actuellement en ligne

15 membres et 109 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 207
Messages
2 086 240
Membres
103 162
dernier inscrit
fcfg