Automatisation d'une macro sur pusieurs tableurs

Bonjour à tous,

Je viens vous demander un peu d'aide pour un problème de macros sur Excel.

J'ai 75 fichiers d'environ 300 000 cellules chacun que je voudrais traiter à l'aide de macros. J'ai par exemple besoin de supprimer certaines cellules et d'en ramener d'autres vers la gauche afin de créer un tableur propre avec des colonnes bien alignées contenant le même type de données (auteur, date, etc.). J'ai réalisé une macro qui semble fonctionner mais le traitement est extrêmement long!! (environ 20 minutes pour 500 lignes)

Voici la macro :

Sub Select_Suppr()

Do

If Cells.Find(What:="Alphabet du titre") Is Nothing Then

Exit Do

Else

Cells.Find(What:="Alphabet du titre").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="Mémoire") Is

Nothing Then

Exit Do

Else

Cells.Find(What:="Mémoire").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="Langue(s) : ") Is Nothing Then

Exit Do

Else

Cells.Find(What:="Langue(s) : ").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="Description : ") Is Nothing Then

Exit Do

Else

Cells.Find(What:="Description : ").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="Accès en ligne : ") Is Nothing Then

Exit Do

Else

Cells.Find(What:="Accès en ligne").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="<a target=") Is Nothing Then

Exit Do

Else

Cells.Find(What:="<a target=").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="Format du document : ") Is Nothing Then

Exit Do

Else

Cells.Find(What:="Format du document : ").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="Alphabet du titre") Is Nothing Then

Exit Do

Else

Cells.Find(What:="Alphabet du titre").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Do

If Cells.Find(What:="Configuration requise") Is Nothing Then

Exit Do

Else

Cells.Find(What:="Configuration requise").Activate

Selection.Delete Shift:=xlToLeft

End If

Loop

Actuellement je dois diviser chaque fichier en tableur de 500 lignes seulement, attendre 20 minutes que celui-ci soit traité puis répéter l'opération sur chaque fichier (si je lance l'opération sur le fichier complet, cela prend plus d'une quinzaine d'heures..).

Mes questions sont donc:

Existe-t-il un moyen d'automatiser cette macro afin que tous mes fichiers soient traités à la suite et sans que j'aie besoin de recopier les instructions à chaque fois?

Puis-je diviser les fichiers automatiquement en fichiers de 500 lignes? (ils contiennent actuellement 10 000 lignes chacun et pour que le traitement soit efficace 500 lignes semblent convenir)

L'idéal étant de pouvoir donner des instructions sur plusieurs machines à la fois, et que celles-ci traitent tous les fichiers automatiquement!

Merci de votre aide et n'hésitez pas à demander des précisions si ce n'est pas clair.

Bonjour,

Et

Pas facile, sans voir la structure de ton fichier...

Est-ce que les cellules contenant les valeurs à chercher ne contiennent que ces valeurs?

Si c'est le cas, tu peux essayer avec ce code :

Sub Select_Suppr()
Dim ASuppr
Dim I As Byte
ASuppr = Array("Alphabet du titre", "Mémoire", "Langue(s) : ", "Description : ", "Accès en ligne : ", "<a target=", _
            "Format du document : ", "Alphabet du titre", "Configuration requise")

For I = LBound(ASuppr) To UBound(ASuppr)
    Cells.Replace What:=ASuppr(I), Replacement:="", LookAt:=xlPart
Next I
Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub

Sinon, il faudra que tu joignes un exemple de ton fichier, exempt de données confidentielles, mais contenant un nombre significatif de données, notamment celles à supprimer.

bon courage

Bonjour et merci,

Non, les cellules contiennent par exemple "format du document : PDF", etc. Dans le fichier joint, les colonnes à supprimer sont : C, D et quelques autres et le but du jeu ici est de ramener les cellules suivantes vers la gauche pour ne pas laisser de vide.

Mais le plus important est surtout de trouver un système pour automatiser le processus pour mes 75 tableurs de 10 000 lignes chacun!!!!!

Re-,

Est-ce que ces données proviennent d'une importation d'un logiciel quelconque?

si c'est le cas, on pourrait peut-être traiter à la source cette importation?

@ te relire

Non impossible et c'est bien pour ça que c'est la galère!

Et une autre question :

Dans le fichier exemple que tu as fourni, si je fais la recherche sur Mémoire, effectivement, dans la colonne C, on retrouve ce mot, mais également dans la cellule Q8

Je suppose qu'il ne faut pas supprimer cette cellule???

rmathieu a écrit :

Non impossible et c'est bien pour ça que c'est la galère!

qu'entends-tu par "impossible"?

Impossible de traiter à la source l'importation. Le tableur tel qu'il est résulte déjà d'un premier traitement.

Non il faut supprimer la colonne C entière, mais pas Q8.

Re-,

bon, ce n'est pas avec tes explications qu'on va avancer....

si tu as peur d'écrire, faut le dire....

Parce que, même avec ton code, la cellule Q8 aurait été supprimée....

Donc il faut bien plus de précisions si tu veux arriver à quelque chose...

Par exemple, est-ce que ces mots se trouvent "TOUJOURS" dans les premières colonnes (De A à F, par exemple)...

Ou jamais dans les colonnes A et B, et jamais après la colonne H

Bref, quelque chose de bien plus clair....

Edit : et c'est quoi, ce premier traitement?

Excuse-moi, je me suis visiblement mal exprimé.

Déjà, merci pour ta proposition de code pour la suppression de cellule : elle est bien mieux optimisée que mon code ne l'était (je me tapais x fonctions If au lieu d'utiliser l'array dans une seule, grosse perte de temps de mon côté).

Mais ce dont j'avais besoin n'était pas par rapport à cette fonction, mais bien par rapport à l'exécution de cette fonction sur l'ensemble des fichiers qui se trouvent dans le même dossier. Comme j'expliquais, j'ai actuellement 75 fichiers contenant chacun 10 000 enregistrements et, même si j'imagine que l'optimisation améliorerait les performances de l'ordinateur, je veux trouver un moyen de lancer la macro UNE SEULE FOIS et qu'elle s'exécute sur chacun des fichiers du répertoire sans nouvelle intervention de ma part.

Et c'est là que le bât blesse car, si j'ai trouvé des scripts sur le net, je n'arrive pas à les configurer correctement. J'ai progressé depuis ce matin, mais j'ai encore un problème majeur : le script tourne bien autant de fois que j'ai de fichiers dans le dossier, mais il ne travaille QUE sur le premier fichier. Et je n'arrive pas à trouver comment je suis supposé configurer l'ouverture du fichier pour qu'il traite le bon.

Voici le code actuel (la fonction appelée n'est pas celle de suppression de cellule mais de scission du fichier en séries de 500 enregistrements, mais bon, c'est pas la fonction elle-même qui pose souci, mais le fichier sur lequel est travaille).

Je pense que le problème réside dans le Workbook.Open au début de la fonction CopieNewFiles ou dans le Windows().Activate à la fin de la fonction, mais mes tentatives pour intégrer "nomFichier" dans le Windows m'ont généré des erreurs. Donc... Help ?

' Déclaration des constantes globale du module
Const cteRepertoire = "C:\Users\(chemin)\test macro 2\"
Const cteNvRepertoire = "C:\Users\(chemin)\transfo macro\"
Const cteExcel = ".xlsm"

Sub gestionFichiers()
    Dim boucle As Integer
    boucle = 1

    Dim j As Integer
    j = 1

    Dim varFichier As Variant

    varFichier = Dir(cteRepertoire & "*" & cteExcel, vbDirectory)

    Do While varFichier <> ""
        Call CopieNewFiles(varFichier, j)
        j = j + 1
        varFichier = Dir()
    Loop

End Sub

Function CopieNewFiles(ByVal nomFichier As String, ByVal boucle As String)
    '

    Dim fichier As Workbook
    Set fichier = Workbooks.Open(cteRepertoire & nomFichier)

    Dim i As Integer
    Dim debut As Integer
    Dim etendue As Integer
    Dim fin As Integer
    Dim NbCopie As Integer

    i = 1 'définit le nombre à affecter au nom du nouveau classeur
    debut = 1 'définit la première ligne à copier
    etendue = 500 ' définit le nombre d'enregistrements par fichier final
    fin = etendue 'définit la fin de la plage à copier, donc nombre de ligne à copier à chaque fois
    NbCopie = Application.RoundUp((Application.Subtotal(3, Sheets(2).Range("a:a")) / fin), 0)
    'NbCopie = (Nombre total de ligne / le nombre de ligne à copier) arrondi au supérieur

    'On fait une boucle sur la base du nombre de Copie
    For i = 1 To 2 'NbCopie

        Dim derniereLigne As Integer
        derniereLigne = Application.Subtotal(3, Sheets(2).Range("a:a"))

        If (derniereLigne < fin) Then
            fin = derniereLigne ' Ici, on vérifie le nombre de lignes de la dernière série d'enregistrements d'un fichier (en général, c'est plutôt 99xx, suite à la suppression de doublons) pour ne pas avoir de messages d'erreurs avec la récupération des infos. 
        End If

        ActiveWorkbook.Sheets(2).Range(Cells(debut, 1), Cells(fin, 52)).Copy 'On choisit la plage selon la ligne de Début et fin sur la colonne 52 =>AZ
        Workbooks.Add 'On ouvre un nouveau classeur
        ActiveSheet.Paste 'Par défaut dans la feuille 1 cellule A1
        ActiveWorkbook.SaveAs Filename:=cteNvRepertoire & boucle & " nom_generique " & "_" & (debut + (boucle - 1) * 10000) & "-" & (fin + (boucle - 1) * 10000) ' On nomme les fichiers en fonction du numéro du fichier d'origine (boucle) puis en indiquant le nombre d'enregistrements couverts
        ActiveWorkbook.Close

        Windows("premier_fichier.xlsm").Activate 'On retourne sur le fichier source

        debut = fin + 1
        fin = fin + etendue

    Next i

End Function

PS : Pour la fonction de suppression, toute cellule contenant "Mémoire..." doit être supprimée, quelle que soit sa colonne, car les données sont complètement mélangées (malheureusement, c'est le mieux qu'on a pu faire pour les récupérer) et on supprime donc les données inutiles à nos besoins pour pouvoir traiter le reste plus facilement.

Re-,

Bon, déjà pour la suppression, comme tu me confirmes que toutes les cellules contenant une des valeurs prédéfinies doivent être supprimées, il suffit de rajouter une étoile à la fin de chaque valeur cherchée, comme ceci :

Sub Select_Suppr()
Dim ASuppr
Dim I As Byte
ASuppr = Array("Alphabet du titre*", "Mémoire*", "Langue(s) : *", "Description : *", "Accès en ligne : *", "<a target=*", _
            "Format du document : *", "Alphabet du titre*", "Configuration requise*")

For I = LBound(ASuppr) To UBound(ASuppr)
    Cells.Replace What:=ASuppr(I), Replacement:="", LookAt:=xlPart
Next I
Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub

Maintenant, pour l'autre souci, est-ce que tu confirmes que tous les fichiers sont dans le même répertoire, et que ce répertoire ne contient que des fichiers à traiter (le fichier contenant le code pourra se trouver n'importe où...)

Et est-ce que tu confirmes que tous les fichiers ont la même structure, avec 1 seul onglet, ou tout au moins que les données se situent sur le premier onglet?

Merci pour le code de suppression.

Pour la gestion des fichiers, oui, tous les fichiers sont dans le même répertoire (actuellement, dans le code, c'est "test macro 2") et les nouveaux fichiers seront enregistrés dans leur propre répertoire ("transfo macro").

Les infos à transférer ne sont pas dans la feuille 1 mais dans la feuille 2 (par contre, elles sont TOUJOURS dans la feuille 2).

Re-,

Juste une question bête...

Pourquoi n'essaies-tu pas de traiter tous les fichiers tels quels, avec le code que je t'ai fourni?

Fais un essai, pour voir le temps de traitement..

Je viens de lancer la procédure avec ton code, et ça défile effectivement beaucoup, beaucoup plus rapidement (de l'ordre de 5-10mn par fichier de dix mille). (j'ai déjà dit merci, au fait, pour l'optimisation ? il me semble, mais je réitère )

Malgré tout, ça reste pénible de faire ça 75 fois (surtout que, même en divisant donc par, mettons, neuf opérations par heure en moyenne, ça signifie huit heures de perdues, vu que ce n'est pas avec cinq minutes de délai entre deux opérations que j'ai la possibilité de faire quoi que ce soit de constructif) et, maintenant que j'ai recherché comment automatiser une application de macro, j'aimerais bien terminer ce code et comprendre pourquoi il ne fonctionne pas...

(en plus, ça pourrait servir à une autre occasion, on sait jamais)

Re-,

Je ne vais pas essayer de traiter ta macro (diviser tes feuilles en 500 lignes)...

De toute manière, ce serait une perte de temps encore plus grande, maintenant que mon code peut faire ce que tu désires en moins de 10 minutes.

Par contre, avec ton début de code, tu peux très bien faire tous les fichiers à suivre, en appliquant mon code à tous tes fichiers situés dans le répertoire ad-hoc.

Bon courage

La division des fichiers en séries de 500 ne sert effectivement plus à rien.

Mais j'ai quand même besoin de faire 75 fois l'opération de suppression des cellules, et donc, plutôt que d'appeler la fonction CopieNewFiles par le processus gestionFichiers, ça reste intéressant d'utiliser gestionFichiers pour appeler Select_Suppr.

Comme je disais : ça peut permettre d'éviter de passer une journée pleine à relancer le processus toutes les dix minutes.

Or, le problème que j'ai rencontré avec CopieNewFiles (il récupérait les données dans le même fichier) se répercutera logiquement sur Select_Suppr, vu que je ne comprends pas pourquoi il n'ouvre pas le bon fichier.

C'est même pire parce que, en appel de fonction, je n'arrive même pas à ouvrir la bonne feuille de calcul, j'ai l'impression :

(cteExcel et cteRepertoire sont les mêmes que précemment)

Sub gestionFichiers()
    Dim boucle As Integer
    boucle = 1

    Dim j As Integer
    j = 1

    Dim varFichier As Variant

    varFichier = Dir(cteRepertoire & "*" & cteExcel, vbDirectory)

    Do While varFichier <> ""
        Call Select_Suppr(varFichier)
        j = j + 1
        varFichier = Dir()
    Loop

End Sub

Function Select_Suppr(ByVal nomFichier As String)
    Dim fichier As Workbook
    Set fichier = Workbooks.Open(cteRepertoire & nomFichier)
    Sheets(2).Select

    Dim ASuppr
    Dim I As Byte
    ASuppr = Array("Alphabet du titre*", "Mémoire*", "Langue(s) : *", "Description : *", "Accès en ligne : *", "<a target=*", _
            "Format du document : *", "Alphabet du titre*", "Configuration requise*")

    For I = LBound(ASuppr) To UBound(ASuppr)
        Cells.Replace What:=ASuppr(I), Replacement:="", LookAt:=xlPart
    Next I
    Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Function

Bonjour,

Essaie avec ce code

Attention aux répertoires, mets les tiens

Et tu confirmes que les données sont dans la sheets(2) de tous les fichiers à traiter

Et qu'également, dans le répertoire source, il n'y a que les fichiers à traiter....

Attention, j'ai créé un sous-répertoire "New" dans le répertoire source, et tous les fichiers sont copiés dedans, donc à mettre à jour sur ton PC

Sub Tous_Fich()
Dim Rep1 As String, Rep2 As String, Fich As String
Dim Fso As Object
Dim Calc As Long
With Application
    .ScreenUpdating = False
    Calc = .Calculation
    .Calculation = xlCalculationManual
End With
Rep1 = "C:\Users\TonNom\Documents\rmathieu\" 'le répertoire source
Rep2 = "C:\Users\TonNom\Documents\rmathieu\New\" 'le répertoire de destination
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFile Rep1 & "*.*", Rep2 'on copie tous les fichiers du 1 vers le 2
Fich = Dir(Rep2 & "*.*")
ChDir Rep2
Do While Fich <> ""
    Workbooks.Open Filename:=Fich
    Select_Suppr (2)  'on déroule le code, ici 2 signifie qu'on va travailler sur la sheets(2)
    ActiveWorkbook.Close True
    Fich = Dir
Loop
Application.Calculation = Calc
End Sub
Sub Select_Suppr(Num As Byte)
Dim ASuppr
Dim I As Byte
ASuppr = Array("Alphabet du titre*", "Mémoire*", "Langue(s) : *", "Description : *", "Accès en ligne : *", "<a target=*", _
            "Format du document : *", "Alphabet du titre*", "Configuration requise*")
With Sheets(Num)
    For I = LBound(ASuppr) To UBound(ASuppr)
        .Cells.Replace What:=ASuppr(I), Replacement:="", LookAt:=xlPart
    Next I
    .Cells.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End With
End Sub

Bon courage

(ça risque de prendre du temps, mais c'est mieux qu'à la main...)

Si tu pouvais me donner le temps de traitement, juste pour ma curiosité naturelle....

Re,

Il me fait bien la copie des fichiers, mais dès qu'il attaque la suite, j'ai une "Erreur 1004 : Erreur définie par l'application ou par l'objet". (j'ai surveillé lors d'un essai : je vérifiais où il en était des copies dans le dossier "traites" [j'ai préféré ce nom à "New"] et c'est juste après que j'ai vu apparaître le 75° fichier que le message d'erreur est apparu sur VBA)

J'ai fait des tests en mettant des parties du code en commentaire, et le plantage semble se produire avec "Workbooks.Open Filename:=Fich" (j'ai tenté également en mettant "Rep2 & Fich" pour le nom)

(et oui, je confirme : que les fichiers à traiter dans le dossier source, et les données sont uniquement dans la seconde feuille de calcul)

Re,

Ok,

On va y aller pas à pas...

Tout d'abord, tu n'as pas commenté CHDir Rep2, j'espère....

Maintenant que tous tes fichiers sont copiés dans le nouveau répertoire, tu commentes la partie de copie

Puis, tu appuies sur F8 pour dérouler le code en mode pas à pas

Quelle est la valeur de Fich lorsque tu arrives à la ligne Workbooks.Open....( passe la souris dessus, tu auras la valeur)?

Si la valeur est bonne, id qu'elle correspond à un nom de fichier valide, je pense que tu as commenté la ligne précédemment citée..

@ te relire

Bonjour,

Ben, non, justement, je n'ai pas commenté ChDir. Pas à cette étape.

En fait, pour expliquer rapidement j'ai commenté tout ce qui était dans le Sub, puis j'ai décommenté en commençant par le haut, justement pour qu'aucune action ne puisse se faire sans avoir les pré-requis (évidemment, quand j'ai eu le Do, j'ai décommenté le Loop en même temps, et j'ai même décommenté le Application.Calculation avant de décommenter le Do While).

je viens de faire l'exécution "pas à pas", et Fich a bien la valeur du premier fichier. J'ai même fait un test pour vérifier qu'il était dans le bon dossier en changeant le nom du premier fichier (pour changer l'ordre), et il en a bien tenu compte.

Mais j'ai toujours la même erreur dès que je fais F8 après être arrivé sur Workbooks.Open...

Et j'ai fait le test en décommentant tout (hormis la copie des fichiers, bien sûr). J'ai aussi vérifié que Rep2 a bien la bonne valeur à la ligne ChDir (en même temps, autrement, Fich n'aurait pas du tout la bonne valeur, non ?).

(j'ai aussi revérifié que je n'avais pas altéré ton code d'une manière ou d'une autre, mais je ne vois rien qui diffère, hormis les chemins d'accès, mais ça, c'est normal)

Bonjour,

Peut-être à cause de ta version sur MAC?

Sur PC, ça fonctionne tout à fait normalement...

Comme je n'ai pas de MAC, ça va pas être simple pour t'aider...

si tu lances l'enregistreur de macro, que tu ouvres un fichier, est-ce que la syntaxe est exactement la même?

Quelle ligne de code utilises-tu d'habitude pour ouvrir un fichier?

Pas trop d'idées, désolé...