Macro donnant le nom de mes fichiers excel à mes feuilles excel

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