Astuce: Les autres langues sont Google-Traduction. Vous pouvez visiter le English version de ce lien.
Se connecter
x
or
x
x
S'enregistrer
x

or

Comment exécuter une macro en même temps dans plusieurs fichiers de classeur?

Cet article, je vais parler de la façon d'exécuter une macro à travers plusieurs fichiers de classeur en même temps sans les ouvrir. La méthode suivante peut vous aider à résoudre cette tâche dans Excel.

Exécuter une même macro sur plusieurs classeurs avec du code VBA


Exécuter une même macro sur plusieurs classeurs avec du code VBA

Pour exécuter une macro sur plusieurs classeurs sans les ouvrir, appliquez le code VBA suivant:

1. Maintenez le ALT + F11 clés pour ouvrir le Microsoft Visual Basic pour applications fenêtre.

2. Cliquez insérer > Moduleet collez la macro suivante dans le Module Fenêtre.

Code VBA: exécutez la même macro sur plusieurs classeurs en même temps:

Sub LoopThroughFiles()
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xls*")
        Do While xFileName <> ""
            With Workbooks.Open(xFdItem & xFileName)
                'your code here
            End With
            xFileName = Dir
        Loop
    End If
End Sub

Note: Dans le code ci-dessus, copiez et collez votre propre code sans le Sous cap et End Sub pied de page entre le Avec Workbooks.Open (xFdItem & xFileName) et Terminer par scripts. Voir la capture d'écran:

doc exécute plusieurs fichiers 1

3. Puis appuyez F5 clé pour exécuter ce code, et un Feuilleter fenêtre est affichée, s'il vous plaît sélectionner un dossier qui contient les classeurs que vous souhaitez tous appliquer cette macro, voir capture d'écran:

doc exécute plusieurs fichiers 2

4. Et puis cliquez OK bouton, la macro souhaitée sera exécutée à la fois d'un classeur à d'autres.


Kutools for Excel résout la plupart de vos problèmes et augmente votre productivité de 80%

  • Réutilisation: Insérer rapidement formules complexes, graphiques et tout ce que vous avez utilisé auparavant; Crypter les cellules avec mot de passe Créer une liste de diffusion et envoyer des emails ...
  • Super Formula Bar (éditez facilement plusieurs lignes de texte et de formule); Disposition de lecture (facilement lire et éditer un grand nombre de cellules); Coller à la gamme filtrée...
  • Fusionner les cellules / rangées / colonnes sans perdre de données; Contenu des cellules divisées; Combiner les lignes / colonnes en double... Prévenir les cellules en double; Comparer les plages...
  • Sélectionnez Dupliquer ou Unique Des rangées; Sélectionnez les lignes vierges (toutes les cellules sont vides); Super Find et Fuzzy Find dans de nombreux cahiers d'exercices; Sélection aléatoire ...
  • Copie exacte Plusieurs cellules sans changer la référence de la formule; Créer automatiquement des références à plusieurs feuilles; Insérer des balles, Cases à cocher et plus ...
  • Extrait du texte, Ajouter du texte, Supprimer par position, Supprimer l'espace; Créer et imprimer des sous-totaux de pagination; Conversion entre contenu de cellules et commentaires...
  • Super filtre (enregistrer et appliquer des schémas de filtrage à d'autres feuilles); Tri avancé par mois / semaine / jour, fréquence et plus; Filtre spécial en gras, en italique ...
  • Combinaison de classeurs et de feuilles de calcul; Fusionner les tables en fonction des colonnes clés; Fractionner les données en plusieurs feuilles; Conversion par lots xls, xlsx et PDF...
  • Plus que de puissantes fonctionnalités 300. Prend en charge Office / Excel 2007-2019 et 365. Prend en charge toutes les langues. Déploiement facile dans votre entreprise ou organisation. Fonctionnalités complètes Essai gratuit du jour 30.
kte tab 201905

Office Tab apporte une interface à onglets à Office et simplifie grandement votre travail

  • Activer l'édition par onglets et la lecture dans Word, Excel, PowerPoint, Publisher, Access, Visio et Project.
  • Ouvrez et créez plusieurs documents dans de nouveaux onglets de la même fenêtre, plutôt que dans de nouvelles fenêtres.
  • Augmente votre productivité de 50% et réduit le nombre de clics de souris pour vous chaque jour!
fond officetab
Say something here...
symbols left.
You are guest ( Sign Up? )
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Ltrung · 4 days ago
    Hi!

    I try to insert my code into yours and when I run the macro it gives me the following message: Run-time error '429': ActiveX can't create the object. Please advised on how it can be fixed. Thank you!

    My code:

    Set RInput = Range("A2:A21")
    Set ROutput = Range("D2:D22")

    Dim A() As Variant
    ReDim A(1 To RInput.Rows.Count, 0)
    A = RInput.Value2

    Set d = CreateObject("Scripsting.Dictionary")

    For i = 1 To UBound(A)
    If d.Exists(A(i, 1)) Then
    d(A(i, 1)) = d(A(i, 1)) + 1
    Else
    d.Add A(i, 1), 1
    End If
    Next
    For i = 1 To UBound(A)
    A(i, 1) = d(A(i, 1))
    Next

    ROutput = A
  • To post as a guest, your comment is unpublished.
    Caitlin Jarvis · 3 months ago
    Hi, firstly thank you for this macro, it was exactly what I was looking for. I do however have one problem, is there a way to close and save as each window as it completes. I have a large amount of files and I'm running out of RAM before the execution is complete.
    • To post as a guest, your comment is unpublished.
      skyyang · 3 months ago
      Hello, Caitlin ,
      Maybe the below code can help you, each time after running your specific code, a save file prompt box will pop out remind you to save the workbook.

      Sub LoopThroughFiles()
      Dim xFd As FileDialog
      Dim xFdItem As Variant
      Dim xFileName As String
      Dim xWB As Workbook
      Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
      If xFd.Show = -1 Then
      xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
      xFileName = Dir(xFdItem & "*.xls*")
      On Error Resume Next
      Do While xFileName <> ""
      Set xWB = Workbooks.Open(xFdItem & xFileName)
      With xWB
      'your code here
      End With
      xWB.Close
      xFileName = Dir
      Loop
      End If
      End Sub
    • To post as a guest, your comment is unpublished.
      Manvir Rai · 3 months ago
      Yes, Just add the below your following code if you wish it to save the file with the same name:

      'Saving the Workbook
      ActiveWorkbook.Save
  • To post as a guest, your comment is unpublished.
    Joel · 7 months ago
    Very useful macro, and it works great, but I would like to be able to select which files from that folder I want the macro to be ran on? For example I have 4 files in a folder with other excel files and I only want it ran on those 4 specific files. How can I tweak your macro to let me pick those 4 files from that folder?
    • To post as a guest, your comment is unpublished.
      skyyang · 7 months ago
      Hi, Joel,
      To trigger the same code in specific workbooks, you should apply the below code:

      Sub LoopThroughFiles()
      Dim xFd As FileDialog
      Dim xFdItem As Variant
      Dim xFileName As String
      Dim xFB As String
      With Application.FileDialog(msoFileDialogOpen)
      .AllowMultiSelect = True
      .Filters.Clear
      .Filters.Add "excel", "*.xls*"
      .Show
      If .SelectedItems.Count < 1 Then Exit Sub
      For lngCount = 1 To .SelectedItems.Count
      xFileName = .SelectedItems(lngCount)
      If xFileName <> "" Then
      With Workbooks.Open(Filename:=xFileName)
      'your code
      End With
      End If
      Next lngCount
      End With
      End Sub

      Please try it, hope it can help you!
      • To post as a guest, your comment is unpublished.
        Ltrung · 4 days ago
        Hi!

        I try to insert my code into yours and when I run the macro it gives me the following message: Run-time error '429': ActiveX can't create the object. Please advised on how it can be fixed. Thank you!

        My code:

        Set RInput = Range("A2:A21")
        Set ROutput = Range("D2:D22")

        Dim A() As Variant
        ReDim A(1 To RInput.Rows.Count, 0)
        A = RInput.Value2

        Set d = CreateObject("Scripsting.Dictionary")

        For i = 1 To UBound(A)
        If d.Exists(A(i, 1)) Then
        d(A(i, 1)) = d(A(i, 1)) + 1
        Else
        d.Add A(i, 1), 1
        End If
        Next
        For i = 1 To UBound(A)
        A(i, 1) = d(A(i, 1))
        Next

        ROutput = A
      • To post as a guest, your comment is unpublished.
        Belema · 4 months ago
        thanks, was really helpful
  • To post as a guest, your comment is unpublished.
    yarto logistics · 7 months ago
    I followed instructions but get a compile error "Loop wihtout Do". What am i missing? My macro code is very simple just change font size of specified rows. Works by it self. Here is what I have... please help

    Sub LoopThroughFiles()
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
    xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
    xFileName = Dir(xFdItem & "*.xls*")
    Do While xFileName <> ""
    With Workbooks.Open(xFdItem & xFileName)
    'your code here
    Rows("2:8").Select
    With Selection.Font
    .Name = "Arial"
    .Size = 12
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -11518420
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
    End With
    xFileName = Dir
    Loop
    End If
    End Sub
    • To post as a guest, your comment is unpublished.
      skyyang · 7 months ago
      Hello, yarto,
      You missed the "End with" script at the end of your code, the correct one should be this:
      Sub LoopThroughFiles()
      Dim xFd As FileDialog
      Dim xFdItem As Variant
      Dim xFileName As String
      Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
      If xFd.Show = -1 Then
      xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
      xFileName = Dir(xFdItem & "*.xls*")
      Do While xFileName <> ""
      With Workbooks.Open(xFdItem & xFileName)
      'your code here
      Rows("2:8").Select
      With Selection.Font
      .Name = "Arial"
      .Size = 16
      .Strikethrough = False
      .Superscript = False
      .Subscript = False
      .OutlineFont = False
      .Shadow = False
      .Underline = xlUnderlineStyleNone
      .Color = -11518420
      .TintAndShade = 0
      .ThemeFont = xlThemeFontNone
      End With
      End With
      xFileName = Dir
      Loop
      End If
      End Sub

      Please try it, hope it can help you!
  • To post as a guest, your comment is unpublished.
    Iulia Curtman · 11 months ago
    Very useful macro, and it works fine, but I would like to be able to select which files from that folder I want the macro to be ran on? The files are not generated automatically in a separate folder, and I need to run different macros on each set of files from that folder, and then move them back in the initial folder.