Générer autant d'onglet que de fichier Excel présent dans le dossier

Question

Il y a bien un domaine où je ne maitrise pas une miettes c'est bien : ET ben non ce soir je ne parle pas de Power Query ! Non, c'est la gestion de fichiers "extérieurs" au fichier Excel ouvert. Mon intention est celle-ci : J'ai un fichier Excel comportant une macro, je la lance. Cette dernière "scanne" le dossier où il se trouve, et pour chaque fichier Excel trouvé (il n'y aura que ça dans le dossier) la macro copiera la seule feuille contenu dans ce fichier (peut importe le nom de la feuille) et la copiera sur le fichier comportant la macro, une fois copiée cet onglet devra porter le nom du classeur dont la feuille provient. Alors je vais dire comme beaucoup de demandeur : cela ne me semble pas trop compliqué, mais je ne connais pas les instructions de gestions de fichiers. Mes applications sont pour la très grande majorité "autonomes" ! Je vous joint pour l'exemple deux fichiers : LRD et GRD : qui comportent comme annoncé une seule feuille dont le nom importe peu. Et une fichier résultat pour vous montrer le résultat attendu : il y a donc trois feuilles, une feuille "Action", puis la feuille "LRD" et la feuille "GRD". L'ordre des feuilles importées n'a pas d'importance. Le nombre de fichier est "inconnu". J'imagine donc une boucle "tant qu'il reste un fichier". il sera possible pour une gestion simplifier de renommer à votre convenance le fichier comportant la macro, voir même le déplacer dans le dossier parent de celui comportant les autres fichiers et ce dossier pourra porter le nom que vous voulez. Merci @ vous. @ bientôt LouReeD...

JExceL2fr · Accepted Answer

Voici le code demandé et testé Sub ImportXFichier1Feuille() Dim Chemin As String, NomFic As String Dim Wbk As Workbook, Sht As Worksheet Chemin = ThisWorkbook.Path & "\" NomFic = Dir(Chemin & "*.xlsx") Do While NomFic &lt;&gt; "" Set Wbk = Workbooks.Open(Chemin & NomFic) Wbk.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Wbk.Close SaveChanges:=False NomFic = Dir Loop MsgBox "Import des fichiers terminé" End Sub A+...

Eric_angers · Accepted Answer

Une variante avec quelques ajouts : - Choix du dossier - Ouverture du classeur en lecture seule et sans maj des liaisons éventuelles - Le nom de la feuille ajoutée est = au nom du classeur sans l'extension (sauf si le nom du classeur est &gt;31 caractères, dans ce cas on reprend le nom de la feuille) - Affichage du nombre de fichiers traités Option Explicit Sub Import_Feuilles() Dim Emplacement As String Dim FSO As Object Dim Dossier As Object Dim Fichier As Object Dim Wbk As Workbook Dim Sht As Worksheet Dim i As Integer ' Choix du dossier With Application.FileDialog(msoFileDialogFolderPicker) ' Fenêtre de sélection d'un dossier (constante =4) .Title = "Sélectionnez un emplacement." .ButtonName = "Sélectionner" .InitialFileName = "C:\" .Show If .SelectedItems.Count &gt; 0 Then Emplacement = .SelectedItems(1) ' Nom du dossier avec chemin (vide si abandon) End With If Emplacement &lt;&gt; "" Then Application.ScreenUpdating = False Set FSO = CreateObject("Scripting.FileSystemObject") Set Dossier = FSO.GetFolder(Emplacement) For Each Fichier In Dossier.Files If UCase(Right(Fichier, 5)) = ".XLSX" Then ' Uniquement les classeur Xlsx Set Wbk = Workbooks.Open(Fichier, 0, True) ' Ouvre en lecture seule et sans maj des liaisons On Error Resume Next ' Err si nom du classeur &gt;31 caractères ' Le nom sera le nom de la Feuille source Wbk.Sheets(1).Name = Left(Fichier.Name, Len(Fichier.Name) - 5) ' Affecte le nom du classeur (sans l'ext) à la feuille 1 On Error GoTo 0 Wbk.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ' Copie en dernier Wbk.Close SaveChanges:=False ' Ferme sans maj i = i + 1 ' Compteur End If DoEvents Next Fichier ThisWorkbook.Sheets(1).Activate Application.ScreenUpdating = True If i &lt;&gt; 0 Then MsgBox i & " Fichier(s) traité(s)", vbOKOnly Else MsgBox "Aucun fichier Xlsx trouvé", vbOKOnly End If End If End Sub Bonne journée...