XL 2019 VBA - Fichiers Excel par prénoms

Option Explicit
Sub Charge()
Dim Sh  As Worksheet

Set Sh = ActiveSheet
    On Error Resume Next: Sh.Shapes.Range(Array("Rapport")).Delete: On Error GoTo 0
    With Sh.OLEObjects.Add(ClassType:="Forms.Label.1", Left:=20, Top:=20, Width:=200, Height:=100)
        .Name = "Rapport"
        With .Object
            .BorderStyle = fmBorderStyleSingle
            .WordWrap = False
            .AutoSize = True
            .BackColor = &HC0FFFF
            .Caption = "Liste des Fichiers pour " & Sh.Name & "*.xlsx" & vbLf
        End With
        
     ' La partie vraiment concernée par votre demande : -----------------------
        Dim Dossier     As String
        Dim Fichier     As String
        Dossier = ThisWorkbook.Path & "\"
        Fichier = Dir(Dossier & Sh.Name & "*.xlsx")
        Do While Fichier <> ""
            Select Case True
                Case Fichier = ThisWorkbook.Name:   ' Le fichier est le même que celui-ci
                Case IsOpen(Fichier):               ' le fichier est déjà ouvert
                    .Object = .Object & vbLf & Fichier & " déjà ouvert"
                Case Else                           ' le fichier doit etre ouvert
                    .Object = .Object & vbLf & Fichier
                    Workbooks.Open Fichier
            End Select
            Fichier = Dir
         Loop
     ' -------------------------------------------------------------------------
        
        .Object = .Object & vbLf
    End With
Set Sh = Nothing

End Sub
Function IsOpen(Classeur As String) As Boolean
Dim Book As Workbook
On Error Resume Next
    Set Book = Workbooks(Classeur)
        IsOpen = Err.Number = 0
    Set Book = Nothing
End Function