Δεν τα μεταφέρει με τη σωστή σειρά

[ataskin]

Καλησπέρα στην ομάδα.
Εχω σε φάκελο πολλά pdf αρχεία με αύξουσα σειρά πχ. αρχείο1.pdf,αρχείο2.pdf, αρχείο3.pdf κτλ.
Θέλω να αντιγράψω τα ονόματά τους σε μια στήλη excel.
Δίνω τον παρακάτω κώδικα, αλλά μου βγάζει το αρχείο1.pdf μετά το αρχείο10.pdf,το αρχείο2.pdf μετά το αρχείο20.pdf κτλ. Μπορεί να διορθωθεί ;
Option Explicit
Sub GetFileNames()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Επιλέξτε τον φάκελο με την λίστα των αρχείων"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
End If
End With
End Sub