How do I get only the folder names to be listed?

[secoo140]

Hello,
I am creating sequential files.
I am using the sorting function of files to find out how long I have been left.
I got the code ready, it became working with a few modifications.
But it makes my computer very slow because it lists all the files.

I think it will speed up if it just sorts the folder names.
How do you think I can limit this code?
thanks

Dim sayi
Dim sat
Sub klasör_dosya1()
Dim P1 As Worksheet
Dim WB As Workbook
Set WB = ThisWorkbook
kaynak = "S:\TRT\Prostat_Kanseri_PSMA"

Set P1 = WB.Worksheets("P1")
P1.Select

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

deg1 = Split(kaynak, "\")
Cells(1, 1).Value = deg1(UBound(deg1))
sat = 1
If UBound(deg1) > 0 Then
sayi = UBound(deg1)
End If
Liste (kaynak)
Call VBAColumn1
Call findlastrow

End Sub
Private Sub Liste(Yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

deg1 = Split(Yol, "\")
If UBound(deg1) > 0 Then
sut = UBound(deg1) + 1 - sayi
End If


Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=Yol, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(Yol)
fL.GetBaseName (Yol)

sut = sut + 1

If fL.GetFolder(Yol).Files.count > 0 Then
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each Dosya In fL.GetFolder(Yol).Files
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=Dosya, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(Dosya.Name)
sut = sut + 1
Next
End If

On Error GoTo sonraki
For Each f In fL.GetFolder(Yol).Subfolders
Liste (f.Path)
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
sonraki:
Next

End Sub

Sub VBAColumn1()

Range("D:D").Insert
    
With Range("D1:D" & Cells(Rows.count, "C").End(xlUp).Row)
        .Formula = "=Left(C1, 4)"
End With


End Sub

Private Sub findlastrow()
Range("d1").End(xlDown).Copy
Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
With Range("a2")
    .NumberFormat = "0000"
    .Value = .Value
End With
End Sub