Exécuter même macro excel sur plusieurs fichiers excel

en supposant que vous mettiez vos fichiers dans le répertoire" Files " relatif à votre classeur Maître, votre code pourrait ressembler à ceci:

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

Dans cet exemple,DoWork() est votre macro que vous appliquez à tous de vos fichiers. Assurez-vous que vous faites tout votre traitement dans votre macro est toujours dans le contexte de l' wb (cahier ouvert actuellement).

Disclaimer: Toutes les possibilités de manipulation des erreurs ont été négligées par souci de brièveté.

une partie de la question pourrait être Comment puis-je exécuter ceci Sur 1000 fichiers?... Dois-je ajouter cette macro à tous les 1000 classeurs?

une façon de faire ceci est d'ajouter votre macro au fichier PERSONAL.XLSB (parfois, l'extension peut être différent). Ce fichier sera chargé en arrière-plan chaque fois que vous démarrez Excel et rend votre macro disponible à tout moment.

D'abord le personnel.Le fichier XLSB ne sera pas là. Pour créer automatiquement ce fichier, il suffit de commencer enregistrer une macro" factice "(avec le bouton" Enregistrer "en bas à gauche d'une feuille de calcul) et sélectionner" Personal Macro Workbook " pour la stocker.

après avoir enregistré votre macro, vous pouvez ouvrir L'éditeur VBA avec Alt+ F11 et vous verrez le personnel.Fichier XLSB avec la macro" dummy " enregistrée.

j'utilise ce fichier pour stocker des charges de macro générales qui sont toujours disponibles, indépendamment de laquelle .xlsx fichier que j'ai ouvert. J'ai ajouté ces macro à mon propre menu.

un inconvénient de ce fichier macro commun est que si vous lancez plus d'une instance D'Excel, vous obtiendrez un message d'erreur que le personnel.Le fichier XLSB est déjà utilisé par Excel instance Nr.1. Ce n'est pas un problème tant que vous n'ajoutez pas de nouvelles macros en ce moment.

je vous Remercie beaucoup pour ce

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop170206Glidepath\V37\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        BSAQmacro wb

        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub
Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\C:\Users098323\Desktop\EXCL\"
    Filename = Dir(Pathname & "*.xlsx")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        .Worksheets(1).Range("A1").Value = "Hello World!"
    End With
End Sub

pendant l'exécution de ce code son montrant le nom ou le numéro de dossier mauvais. j'ai stocké tout mon fichier dans ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder

au lieu de passer les valeurs à DoWork on peut aussi exécuter les travaux dans Processfiles().

Sub ProcessFiles()

    Dim Filename, Pathname As String
    Dim wb1 As Workbook
    Dim wb2 As Workbook

    Dim Sheet As Worksheet
    Dim PasteStart As Range
    Dim Counter As Integer

    Set wb1 = ActiveWorkbook
    Set PasteStart = [RRimport!A1]

    Pathname = ActiveWorkbook.Path & "\For Macro to run\"
    Filename = Dir(Pathname & "*.xls")
    Do While Filename <> ""
        Set wb2 = Workbooks.Open(Pathname & Filename)
        For Each Sheet In wb2.Sheets
                With Sheet.UsedRange
                .Copy PasteStart
                Set PasteStart = PasteStart.Offset(.Rows.Count)
            End With
        Next Sheet
        wb2.Close
        Filename = Dir()
    Loop
End Sub

Merci Peterm!!

en fait, j'ai fait ma macro en utilisant exactement le même code que vous avez posté (process_fiels et dowork).

Il a travaillé génial!! (avant ma question)

chacun de mes 1000 cahiers A 84 feuilles de travail. Mon propre macro (qui fonctionne enfin!) divise chaque classeur en 85 fichiers différents (l'original + une version abrégée de chaque feuille de travail sauvegardée sous forme de fichier individuel).

cela me laisse avec 1000 fichiers + 1000x85 dans le même dossier, et ce serait vraiment difficile à trier.

Ce que j'ai vraiment besoin, c'est pour Process_Files de prendre le premier fichier, créer un dossier avec le nom du premier fichier, déplacez le premier fichier dans le dossier avec ist nom, puis exécutez ma macro (dans le dossier nommé d'après le premier fichier dans le dossier nouvellement créé...), revenir en arrière et prendre la deuxième fichier, créer un dossier avec le nom du second fichier, déplacez le fichier vers le dossier avec ist nom, puis exécutez ma macro (dans le dossier nommé après le deuxième fichier dans le dossier nouvellement créé...), etc...

à la fin, j'aurais dû déplacer tous les fichiers dans des dossiers avec le même nom que les fichiers, et le contenu du dossier \Files\ original serait de 1000 dossiers avec le nom des fichiers originaux, containgin les fichiers originaux + 84 fichiers ce que ma propre macro fait déjà.

Peut-être que c'est plus facile avec le code:

Sous-Fichiers De Processus() Dim Nom De Fichier, Chemin As String Dim WB As Classeur

Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""

(ici, il doit lire le nom du fichier, Créer un dossier avec le nom du fichier, déplacer le fichier dans ce dossier nouvellement créé)

    Set wb = Workbooks.Open(Pathname & Filename)  <- open file, just as is.
    DoWork wb   <- do my macro,just as is
    wb.Close SaveChanges:=False      <- not save, to keep the original file

(retournez dans le dossier \Files\ original)

    Filename = Dir()   <-   Next file, just as is
Loop

End Sub

Sous-travail(wb comme cahier D'exercices) Avec wb Mamacro Fin Avec End Sub

merci Beaucoup, ce site est génial!

__________________edit, la macro fonctionne maintenant _________________________

comme vous pouvez le voir, Je ne suis pas un expert en VBA, mais la macro fonctionne enfin. Le code n'est pas soigné du tout, Je ne suis pas programmeur SW.

voilà, ça pourrait aider un jour.

Sous-ProcessFiles_All() Dim Nom De Fichier, Chemin D'Accès, NewPath, FileSource, FileDestination Comme Une Chaîne De Caractères Dim wb Comme Classeur

    Pathname = ActiveWorkbook.Path & "\Files\"
    Filename = Dir(Pathname & "*.csv")

 Do While Filename <> ""

     NewPath = Pathname & Left(Filename, 34) & "\"

 On Error Resume Next
     MkDir (NewPath)
 On Error GoTo 0

 Set wb = Workbooks.Open(Pathname & Filename)

    DoWorkPlease wb   '  <------------   It is important to say please!!

Sur La Reprise D'Erreur Suivant wb.Fermer SaveChanges: = False if Err.Nombre < > 0 alors ‘Gestionnaire d'erreur nécessaire ici Fin si

    Filename = Dir()

 Loop

End Sub

sous-Dowworkplease(wb comme classeur) Avec wb

' étant donné que mon application compte plus de 1800 cellules pour chaque colonne et qu'elle prend beaucoup de temps ‘ J'utilise un "mode test" où je ne joue qu'avec 18 valeurs.

 Dim TestingMode As Integer
 Dim ThisRange(1 To 4) As Variant

 TestingMode = 0

If TestingMode = 1 Then
   ThisRange(1) = "B2:CG18"
   ThisRange(2) = "CT2:CT18"
   ThisRange(3) = "CH2:CN18"
   ThisRange(4) = "CN2:CS18"
   Rows("19:18201").Select
   Selection.Delete Shift:=xlUp
End If

If TestingMode = 0 Then
   ThisRange(1) = "B2:CG18201"
   ThisRange(2) = "CT2:CT18201"
   ThisRange(3) = "CH2:CN18201"
   ThisRange(4) = "CN2:CS18201"
End If

‘ accélérer la macro, désactiver la mise à jour et les alertes

Application.ScreenUpdating = False Application.DisplayAlerts = False

‘ Voici mon code qui manipule les valeurs des cellules à partir des chiffres (les valeurs lues par les capteurs doivent être "traduites" en valeurs réelles. Code pas ici en fait.

' ensuite je copie tout le truc en nombres, il n'y a plus de formules, plus faciles à travailler de cette façon.

'_____________________________________ 'Obtenir des valeurs plus les formules

 Sheets.Add After:=Sheets(Sheets.Count)
 Sheets("Sheet1").Select
 Columns("A:CT").Select
 Selection.Copy
 Sheets("Sheet2").Select
 Columns("A:A").Select
 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     :=False, Transpose:=False
 Application.CutCopyMode = False
 Selection.NumberFormat = "0"
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With

' ensuite je sauve ce nouveau classeur dans un dossier avec son propre nom (et sous le dossier \FICHIERS\

'_____________________________________ "Enregistrer le travail en vertu de son propre dossier

Dim CleanName, CleanPath, CleanNewName As Variant CleanPath = ActiveWorkbook.Chemin CleanName = ActiveWorkbook.Nom CleanName = Gauche(CleanName, 34) " je de prendre de l'extension CleanPath = CleanPath + " \ " + CleanName CleanNewName = CleanPath + " \ " + CleanName CleanNewName = CleanNewName + " _clean.csv" et j'ajoute "propre" pour avoir une autre nom maintenant.

Sur La Reprise D'Erreur Suivant ActiveWorkbook.SaveAs Filename: = CleanNewName, FileFormat:= xlCSV, CreateBackup: = False

' S'il y a une erreur, je crée un dossier vide avec le nom du fichier pour savoir quel fichier doit être retravaillé.

If Err.Number <> 0 Then
    MkDir (CleanPath + "_error_" + CleanName)
End If    

' Resume Next

ActiveSheet.Déplacer _ Après: = ActiveWorkbook.Les feuilles(1)

' ensuite j'ai divisé le classeur en fichiers individuels avec les données dont j'ai besoin pour capteur.

‘ Voici les plages individuelles dont j'ai besoin pour chaque fichier. Comme j'ai plus de 1000 fichiers, cela en vaut la peine.

'_______________ le Split!!______________________________

Dim Col(1 À 98) Comme Variante Col (1) = " A: A, B: B, CH:CH, CN, CT: CT" Col (2) = " A: A, C:C, CH:CH, CN: CN, CT: CT" Col (3) = " A: A, D:D, CH:CH, CN, CT: CT" Col (4) = " A: A, E:E, CH:CH, CN, CT: CT" Col (5) = " A: A, F: F, CH:CH, CN: CN, CT: CT" Col (6) = "A:A,G:G,CH:CH,CN: CN, CT: CT" Col (7) = " A: A,H: H, CH:CH, CN, CT: CT" Col (8) = " A: A, I: I, CH:CH, CN, CT: CT" Col (9) = " A: A, J: J, CH:CH, CN, CT: CT" Col (10) = " A: A, K:K, CH:CH, CN, CT: CT" Col (11) = " A: A, L:L, CH:CH, CN, CT: CT" Col (12) = " A: A, M:M, CH:CH, CN, CT: CT" Col (13) = " A: A, N:N, CH:CH, CN: CN, CT: CT" Col (14) = " A: A, O:O, CH:CH, CN, CT: CT" Col(15) = ": P:P,IC:IC,CO:CO,CT:CT" Col (16) = " A:a, Q:Q, CI: CI, CO: CO, CT: CT" Col (17) = " A:A, R:R, CI: CI, CO: CO, CT: CT" Col (18) = "A: A, S:S, CI: CI, CO: CO, CT: CT" Col (19) = " A:A, T:T, CI: CI, CO: CO, CT: CT" Col (20) = " A:A, U: U, CI: CI, CO: CO, CT: CT" Col (21) = " A: A, V:V, CI: CI, CO: CO, CT: CT" Col (22) = " A:A, W:W, CI: CI, CO: CO, CT: CT" Col (23) = " A: A, X:X, CI: CI, CO: CO, CT: CT" Col (24) = " A:A, Y:Y, CI: CI, CO: CO, CT: CT" Col (25) = " A: A, Z:Z, CI: CI, CO: CO, CT: CT" Col (26) = " A:A, AA: AA, CI: CI, CO: CO, CT: CT" Col (27) = " A:A, AB: AB, CI: CI, CO: CO, CT: CT" Col (28) = " A:A, AC: AC, CI: CI, CO: CO, CT: CT" Col (29) = "A:A,AD:AD,CJ:CJ,CP: CP, CT: CT" Col (30) = " A:A,AE: AE, CJ: CJ, CP: CP, CT: CT" Col (31) = " A:A, AF: AF,CJ:CJ, CP: CP, CT: CT" Col (32) = " A:A, AG: AG, CJ:CJ, CP: CP, CT: CT" Col (33) = " A:A, AH: AH, CJ:CJ, CP: CP, CT: CT" Col (34) = " A: A,AI: AI,CJ: CJ, CP: CP, CT: CT" Col (35) = " A: A, AJ:AJ,CJ: CJ, CP: CP, CT: CT" Col (36) = " A: a,AK: AK,CJ: CJ, CP: CP, CT: CT" Col (37) = " A:A, AL: AL,CJ:CJ, CP: CP, CT: CT" Col (38) = " A:A, AM: AM,CJ:CJ, CP: CP, CT: CT" Col (39) = " A: A, AN:AN, CJ: CJ, CP: CP, CT: CT" Col (40) = "A:A,AO:AO,CJ:CJ,CP: CP, CT: CT" Col (41) = " A: A, AP: AP,CJ:CJ, CP: CP, CT: CT" Col (42) = " A: A, AQ:AQ, CJ: CJ, CP: CP, CT: CT" Col (43) = " A: A, AR: AR,CK: CK,CQ: CQ, CT:CT" Col (44) = " A:A, AS: AS, CK: CK,CQ: CQ, CT:CT" Col (45) = " A: A, AT: AT, CK: CK,CQ:CQ, CT:CT" Col (46) = " A: A, AU: AU,CK: CK,CQ: CQ, CT:CT" Col (47) = " A:A, AV: AV,CK: CK,CQ: CQ, CT:CT" Col (48) = " A:A,AW: AW,CK: CK,CQ:CQ, CT:CT" Col (49) = " A: A,AX: AX,CK: CK,CQ: CQ, CT:CT" Col (50) = " A: A, AY: AY, CK: CK,CQ: CQ, CT:CT" Col (51) = "A: A,AZ: AZ,CK: CK,CQ:CQ, CT: CT" Col (52) = " A: A, BA: BA,CK: CK,CQ: CQ, CT:CT" Col (53) = " A: A, BB: BB,CK: CK,CQ:CQ, CT:CT" Col (54) = " A: A, BC: BC,CK: CK,CQ: CQ, CT:CT" Col (55) = " A: A,BD: BD,CK: CK,CQ: CQ, CT:CT" Col (56) = " A:A, BE: BE,CK: CK,CQ: CQ, CT:CT" Col (57) = " A: A, BF: BF,CL:CL, CR:CR, CT: CT" Col (58) = " A: A, BG: BG,CL:CL, CR: CR, CT: CT" Col (59) = " A: A, BH:BH, CL:CL, CR:CR, CT: CT" Col (60) = " A:A, BI: BI, CL:CL, CR: CR, CT: CT" Col (61) = " A: A, BJ:BJ, CL:CL, CR:CR, CT: CT" Col (62) = "A: A, BK:BK, CL:CL, CR: CR, CT: CT" Col (63) = " A:A,BL: BL, CL:CL, CR: CR, CT: CT" Col (64) = " A: A, BM:BM, CL:CL, CR:CR, CT: CT" Col (65) = " A: A, BN: BN,CL:CL, CR:CR, CT: CT" Col (66) = " A: A, BO: BO,CL:CL, CR:CR, CT: CT" Col (67) = " A: A,BP: BP, CL: CL, CR: CR, CT: CT" Col (68) = " A: A, BQ:BQ, CL:CL, CR:CR, CT: CT" Col (69) = " A: A, BR: BR, CL:CL, CR:CR, CT: CT" Col (70) = " A: A, BS: BS,CL:CL, CR:CR, CT: CT" Col (71) = " A: A, BT: BT, CM: CM, CS: CS, CT: CT" Col (72) = " A: A, BU: BU, CM: CM, CS: CS, CT: CT" Col (73) = "A:A,BV:BV,CM: CM, CS: CS, CT: CT" Col (74) = " A:A, BW: BW, CM: CM, CS: CS, CT: CT" Col (75) = " A: A, BX:BX, CM: CM, CS: CS, CT: CT" Col (76) = " A: A,BY: BY,CM: CM, CS: CS, CT: CT" Col (77) = " A: A, BZ: BZ, CM: CM, CS, CT: CT" Col (78) = " A: A, CA: CA, CM: CM, CS: CS, CT: CT" Col (79) = " A: A, CB: CB, CM: CM, CS: CS, CT: CT" Col (80) = " A: A, CC: CC, CM: CM, CS: CS, CT: CT" Col (81) = " A: A, CD: CD, CM: CM, CS: CS, CT: CT" Col (82) = " A:A, CE: CE, CM: CM, CS: CS, CT: CT" Col (83) = " A: A, CF: CF, CM: CM, CS: CS, CT: CT" Col (84) = "A:A,CG: CG, CM: CM, CS: CS, CT: CT" 'Je veux partager 84 nouveaux fichiers, donc pour les tests j'utilise seulement 1, et pour la vraie chose je vais avec 84

Dim CounterMode As Integer

Si TestingMode = 1 Alors CounterMode = 1 Autre CounterMode = 84

For i = 1 To CounterMode

‘ ce code prend les colonnes nécessaires, et les coller dans un nouveau classeur.

 Sheets("Sheet1").Select
 Cells.Select
 Selection.ClearContents
 Range("A1").Activate
 Sheets(2).Select
 Range(Col(i)).Select
 Selection.Copy
 Sheets("Sheet1").Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 With Selection
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlBottom
     .WrapText = False
     .Orientation = 0
     .AddIndent = False
     .IndentLevel = 0
     .ShrinkToFit = False
     .ReadingOrder = xlContext
     .MergeCells = False
 End With
 Columns("A:E").EntireColumn.AutoFit

" Enregistrer le fichier individuel

'_____________save the work________________

Dim ThePath, TheName, TheSwitch As String ThePath = ActiveWorkbook.Chemin+ "\" TheName = Left (ActiveWorkbook.Nom, 34 ‘ " retirez l'extension du nom ThePath = ThePath + TheName TheSwitch = Cells(3, 2) ‘ Dans la Cellule (3,2) j'ai le nom de la personne nom, j'ai donc ajouté au nom de fichier. TheName = ThePath + " _ " + TheSwitch +".xls"

Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Copy

Dim SheetName As Variant

" j'nom de Feuilles(1) dans la feuille Sheet1, depuis la feuille d'origine a le nom et la date de l'épreuve. ‘ Je faire pour avoir le même nom sur tous les fichiers afin de faire un tracé, puis je renommer la feuille avec le ‘ nom original

SheetName = ActiveSheet.Nom ActiveWorkbook.Feuilles (1).Name = "Sheet1"

" voici l'intrigue

Columns("A:E").EntireColumn.AutoFit
Columns("B:E").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E")
ActiveChart.ChartType = xlXYScatterLinesNoMarkers

ActiveWorkbook.Sheets(1).Name = SheetName

" enregistrer On Error Resume Next ActiveWorkbook.SaveAs Filename: = TheName, FileFormat: = 56, CreateBackup:=False

If Err.Number <> 0 Then
    MkDir (ThePath + "_error_" + TheName)
End If

ActiveWorkbook.Close

Ensuite, j'ai '____________________C'était le Split__________________________________ "Activez le screenupdating: Application.ScreenUpdating = True Application.DisplayAlerts = True Portée ("A1").Sélectionnez

 End With

End Sub