Hvordan får man folder navn

Som løsning dog kommer når man nørkler :)

Sub SrchForFiles()
        Dim i As Long, z As Long, Rw As Long
    Dim ws As Worksheet
    Dim y As Variant
    Dim fLdr As String, fil As String, FPath As String
    Dim MyTempList As Variant
    Dim lfldrnm As Integer
    Dim FldrName As String
    Dim FilName As String
    Dim sTmp As String
    Dim t As Long
   
   
    y = "case.xls"
    Application.ScreenUpdating = False
    '**********************************************************************
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        fLdr = .SelectedItems(1)
    End With
    '**********************************************************************
    With Application.FileSearch
        .NewSearch
        .LookIn = fLdr
        .SearchSubFolders = True
        .Filename = y
     
      On Error GoTo 0
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                fil = .FoundFiles(i)
                    'Get file path from file name
                FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
                Workbooks.Open Filename:=fil
                Sheets("Start").Select
                    MyTempList = Split(fil, "\")
                        For t = 0 To UBound(MyTempList)
                        Next t
                    FldrName = MyTempList(UBound(MyTempList) - 1)
                Sheets("Start").Copy After:=Workbooks("Opsamlingssheet.xls").Sheets(1)
                ActiveSheet.Name = FldrName
                Windows("case.xls").Close (True)
                                     
                'FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
               
            Next i
        End If
    End With
   
     
    Exit Sub

End Sub