Macro donnant le nom de mes fichiers excel à mes feuilles excel
RomanJ
Messages postés
8
Statut
Membre
-
RomanJ Messages postés 8 Statut Membre -
RomanJ Messages postés 8 Statut Membre -
Bonjour, ma macro permet pour l'instant de prendre mes fichiers excel qui sont dans un dossier, et pour chaque fichiers, une feuille correspondante se créée. Je souhaiterais renommer chaque nouvelle feuille créée par le nom du fichier excel correspondant. Quelqu'un pourrait-il m'aider svp? :)
Ci-dessous ma macro actuelle:
Sub Macro1()
' Touche de raccourci du clavier: Ctrl+m
Dim dossier As String
dossier = "F:\Excel\Dossier macro\Nouveau dossier\"
Fichier = Dir(dossier & "*.*")
ActiveWorkbook.Worksheets.Add
While Fichier <> ""
Debug.Print dossier & Fichier
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & dossier & Fichier, Destination:=Range("$A1048576").End(xlUp).Offset(1, 0))
.Name = Fichier
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 23
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(9, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Fichier = Dir
Wend
End Sub
Ci-dessous ma macro actuelle:
Sub Macro1()
' Touche de raccourci du clavier: Ctrl+m
Dim dossier As String
dossier = "F:\Excel\Dossier macro\Nouveau dossier\"
Fichier = Dir(dossier & "*.*")
ActiveWorkbook.Worksheets.Add
While Fichier <> ""
Debug.Print dossier & Fichier
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & dossier & Fichier, Destination:=Range("$A1048576").End(xlUp).Offset(1, 0))
.Name = Fichier
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 23
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(9, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Fichier = Dir
Wend
End Sub
1 réponse
-
Bonjour,
prendre mes fichiers excel Z'etes sure de votre fait, avec une connexion en text ???????????????
Sub Macro1() ' Touche de raccourci du clavier: Ctrl+m Dim dossier As String dossier = "F:\Excel\Dossier macro\Nouveau dossier\" Fichier = Dir(dossier & "*.*") While Fichier <> "" ActiveWorkbook.Worksheets.Add ActiveSheet.Name = Fichier With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & dossier & Fichier, Destination:=Range("$A1048576").End(xlUp).Offset(1, 0)) .Name = Fichier .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 850 .TextFileStartRow = 23 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = True .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = True .TextFileColumnDataTypes = Array(9, 1, 1, 1, 1, 1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With Fichier = Dir Wend End Sub
