Yüzlerca dosyayı kendi ismindeki klasore taşıma

[emaema]

bir klasorun icinde yuzlerce ismi sicil numarasi olan pdf ler var. Ben bunlarin her biri için sicil numarasiyla klasör oluşturup bu sicildeki pdfleri de bu klasorlere atmak istiyorum. Makro ile çözebilir miyiz acaba bunu?

 

[hlojan]

Sub ListFiles()
    Dim Directory As String
    Dim r As Long
    Dim f As String
    Dim FileSize As Double
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select a location containing the files you want to list."
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            Directory = .SelectedItems(1) & "\"
        End If
    End With
    r = 1

    Cells.ClearContents
    Cells(r, 1) = "Files in " & Directory
    Cells(r, 2) = "Size"
    Cells(r, 3) = "Date/Time"
    Range("A1:C1").Font.Bold = True
    
    f = Dir(Directory, vbReadOnly + vbHidden + vbSystem)
    Do While f <> ""
        r = r + 1
        
        

  Set fso = CreateObject("Scripting.FileSystemObject")


sSourceFile = Directory & "\" & f

sDestinationFile = Directory & "\" & Cells(r, 1) = Left(f, (InStrRev(f, ".", -1, vbTextCompare) - 1)) & "\" & f

fso.MoveFile sSourceFile, sDestinationFile
    Loop
End Sub