LISTING FILES IN FOLDER - INCORRECT ORDER

[branston]

Hi

I am trying to create a list of filenames in my folder (that are copied in to column A). I am using the code below which sort of works however outputs the files in a different order as to how they are in my folder. I need them in the EXACT same order. I am assuming the Excel is listing them 'alphabetically' and using the numbers at the end of the files to sort? Is there a way of sorting just as the files are? Or could I add a 1,2,3,4.... prefix to each file before copying across to my Excel sheet?

E.g. This is the order in my folder
File1 in my folder is Trees8.pdf
File2 in my folder is Leaves9.pdf
File3 in my folder is Bears10.pdf
File4 in my folder is Sky11.pdf
File5 in my folder is Water12.pdf and so on

However the output listed in Column A in Excel is :

Bears10.pdf
Sky11.pdf
Water12.pdf
Trees8.pdf
Leaves9.pdf

Sub ListFiles()
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
MyFolder = "C:\Users\branston"
MyFile = Dir(MyFolder & "\*.*")
a = 0
Do While MyFile <> ""
    a = a + 1
    Cells(a, 1).Value = MyFile
    MyFile = Dir
Loop
End Sub

[Paul_Hossler]

What is the sort order for the folder? I'm guessing Date Created or Date Modified?

Is so, then you'll probable have to use FileDateTime to get the information about each file and sort the list yourself

https://docs.microsoft.com/en-us/off...etime-function


Or did you want it sorted by the ending number?

[branston]

Hi Paul

I split a (large) PDF file into 123 single pages and have now split it so the files are just called File1.pdf, File2.pdf etc. I thought this would do the trick. The order in the folder is just the order of the pages in the large PDF (from Page 1 to Page 123).

However I have tried running the code below but still having the same issue with some files. Most of the files appear in the correct order but some don't even get re-named starting with File9.pdf then File87.pdf, File88.pdf, File89.pdf all the way to File99.pdf

Option Explicit


Sub test()
  Dim Path As String
  Dim R As Range
  Dim FS As New FileSearch
  Dim i As Long
  Dim OldName As String, NewName As String
  
  'Get the path from this file
  Path = ThisWorkbook.Path
  If Right(Path, 1) <> "\" Then Path = Path & "\"
  
  With FS
    'Search here
    .LookIn = Path
    'for PDF files
    .FileName = "*.pdf"
    'Do it
    .Execute msoSortByFileName, msoSortOrderAscending
    '.Execute msoSortByFileName
    'For each cell in column A
    For Each R In Range("A1", Range("A" & Rows.Count).End(xlUp))
      i = i + 1
      'Rename the file
      OldName = .FoundFiles(i)
      NewName = Path & R.Value & ".pdf"
      Name OldName As NewName
    Next
  End With
End Sub

There is also a separate FileSearch Class Module

[p45cal]

What version of Excel are you using?
There is the File System Object you can use.
[If you want us to look at your code an keep using the FileSearch object we'll need your FileSearch class module too - easiest to attach a file with it already 'installed'.]

[branston]

Version 2102 MS Excel for MS 365 MSO

My file is a bit cumbersome, I've copied the FileSearch code below ... I hope that's ok?

Thanks for all your help.

'Version 2.31
'Andreas Killer
'11.04.2018


'Replica of the office FileSearch object


Option Explicit
Option Compare Text


'Set this define to False if you use Office 2003 or prior versions
#Const UseNewOfficeFileExtensions = True
'Support unicode chars in filenames, otherwise ANSI chars only
#Const UniCode = True


'This event is raised before the search goes into a subdirectory
'  Set Cancel to True to skip that folder (and its subfolders)
Public Event BeforeSearchFolder(ByVal Path As String, ByRef Cancel As Boolean)


#Const FoundEvents = True
#If FoundEvents Then
'This event is raised when a file is found, set Cancel to True to skip that file
Public Event FoundFile(ByVal FullName As String, ByVal Attributes As Long, ByVal DateCreated As Date, _
  ByVal DateLastAccessed As Date, ByVal DateLastModified As Date, ByVal Size As Variant, ByRef Cancel As Boolean)
'This event is raised when a folder is found, set Cancel to True to skip that folder
Public Event FoundFolder(ByVal FullName As String, ByVal Attributes As Long, ByVal DateCreated As Date, _
  ByVal DateLastAccessed As Date, ByVal DateLastModified As Date, ByRef Cancel As Boolean)
#End If


'  Sub Example_FileSearch()
'    Dim ApplicationFileSearch As New FileSearch
'    Dim FName
'    With ApplicationFileSearch
'      'Setup a file mask to search for
'      .FileName = "*.*"
'      'Remarks:
'      'A 3 characters long extension did not find a 4 characters long extension
'      '  Means *.xlsm or *.xlsx files are not found if you search for *.xls
'      '  If you want to include that files, search for "*.xls*"
'      '  If you want to exclude *.xls files, search for "*.xls?"
'      '  Search for *.* to find all files
'      '  Search for *.*.* to find only files with a dot in the filename
'      'You can search with multiple masks at the same time if you use an array
'      '  E.g. if you want to find different picture file types:
'      '  .FileName = Array("*.jpg", "*.jpeg", "*.bmp", "*.gif")
'      '  The .FileType property fills the .FileName property with some predefinied arrays
'      '  E.g. this searches for all Excel files .FileType = msoFileTypeExcelWorkbooks
'
'      'Setup a path to search for files
'      .LookIn = "C:\"
'      'Remarks:
'      '  If the class is initialized or if you call .NewSearch the path is set
'      '  to your personal directory, e.g. "C:\Users\UserName\Documents" on Win7
'
'      'Search through sub folders or not, the default value is False
'      .SearchSubFolders = True
'
'      'If you want to find a files that you have modified, but you can't remember the filename
'      '  use the .LastModified property and specify a time period
'      '  The default value of this property is msoLastModifiedAnyTime
'      '.LastModified = msoLastModifiedToday
'
'      'Execute the search, the number of found files are returned
'      If .Execute > 0 Then
'      'Remarks:
'      '  The argument AlwaysAccurate does nothing, it is only for backward compatibility
'      '  The returned order of the files is unsorted by default
'      '  You can sort by FileName, FileType (Extension), LastModified or Size ascending or descending
'
'      'After a successfully search, two collections are filled with the results:
'      '  .FoundFiles contains all found files
'      '  .FoundDirs contains all found directories
'      '
'      'You can access a collection in 2 ways:
'      '  Many people do an index access like this
'      '  For i = 1 To .FoundFiles.Count
'      '    FName = .FoundFiles(i)
'      '  Next
'
'      'But a FOR EACH loop executes much faster:
'        For Each FName In .FoundFiles
'          'Debug.Print FName
'        Next
'      End If
'    End With
'  End Sub


Public Enum msoSortBy
  msoSortByFileName = 1
  msoSortBySize = 2
  msoSortByFileType = 3
  msoSortByLastModified = 4
End Enum


Public Enum msoFileType
  msoFileTypeAllFiles = 1
  msoFileTypeOfficeFiles = 2
  msoFileTypeWordDocuments = 3
  msoFileTypeExcelWorkbooks = 4
  msoFileTypePowerPointPresentations = 5
  msoFileTypeBinders = 6
  msoFileTypeDatabases = 7
  msoFileTypeTemplates = 8
End Enum


Public Enum msoLastModified
  msoLastModifiedYesterday = 1
  msoLastModifiedToday = 2
  msoLastModifiedLastWeek = 3
  msoLastModifiedThisWeek = 4
  msoLastModifiedLastMonth = 5
  msoLastModifiedThisMonth = 6
  msoLastModifiedAnyTime = 7
End Enum


Public Enum msoSortOrder
  msoSortOrderAscending = 1
  msoSortOrderDescending = 2
End Enum


Public SearchSubFolders As Boolean
Public FoundFiles As Collection
Public FoundDirs As Collection


Private fsFileName As Variant
Private fsFileExt As Variant
Private fsFileBase As Variant
Private fsLookIn As String
Private fsFileType As msoFileType
Private fsLastModified As msoLastModified


Private SortFiles As Collection
Private SortDirs As Collection
Private SortFilesBy As msoSortBy
Private fso As Object 'FileSystemObject


Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260


Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type


Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type


Private Const FIND_FIRST_EX_CASE_SENSITIVE As Long = 1
'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7."
Private Const FIND_FIRST_EX_LARGE_FETCH As Long = 2


Private Enum FINDEX_SEARCH_OPS
  FindExSearchNameMatch
  FindExSearchLimitToDirectories
  FindExSearchLimitToDevices
End Enum


Private Enum FINDEX_INFO_LEVELS
  FindExInfoStandard
  FindExInfoBasic 'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7."
  FindExInfoMaxInfoLevel
End Enum


#If Win64 Then
#If UniCode Then
Private Declare PtrSafe Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" ( _
    ByVal lpFileName As LongPtr, ByVal fInfoLevelId As Long, ByVal lpFindFileData As LongPtr, _
    ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileW" ( _
    ByVal hFindFile As LongPtr, ByVal lpFindFileData As LongPtr) As Long
#Else
Private Declare PtrSafe Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExA" ( _
    ByVal lpFileName As String, ByVal fInfoLevelId As Long, lpFindFileData As WIN32_FIND_DATA, _
    ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATA) As Long
#End If
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
#Else
#If UniCode Then
Private Declare Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" ( _
    ByVal lpFileName As Long, ByVal fInfoLevelId As Long, ByVal lpFindFileData As Long, _
    ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" ( _
    ByVal hFindFile As Long, ByVal lpFindFileData As Long) As Long
#Else
Private Declare Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExA" ( _
    ByVal lpFileName As String, ByVal fInfoLevelId As Long, lpFindFileData As WIN32_FIND_DATA, _
    ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
#End If
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
#End If


Private Type SYSTEMTIME
  wYear As Integer
  wMonth As Integer
  wDayOfWeek As Integer
  wDay As Integer
  wHour As Integer
  wMinute As Integer
  wSecond As Integer
  wMilliseconds As Integer
End Type


#If Win64 Then
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" ( _
    lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpDest As Any, lpSource As Any, ByVal nCount As Long)
#Else
Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
    lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpDest As Any, lpSource As Any, ByVal nCount As Long)
#End If


'Private Type SHITEMID
'  cb As Long
'  abID As Byte
'End Type
'Private Type ITEMIDLIST
'  mkID As SHITEMID
'End Type
'
'#If Win64 Then
'Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "Shell32" ( _
'    ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef ppidl As ITEMIDLIST) As Long
'Private Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" ( _
'    ByVal pidList As Long, ByVal lpBuffer As String) As Long
'#Else
'Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" ( _
'    ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef ppidl As ITEMIDLIST) As Long
'Private Declare Function SHGetPathFromIDList Lib "Shell32" ( _
'    ByVal pidList As Long, ByVal lpBuffer As String) As Long
'#End If


Private IsWow64 As Boolean


#If Win64 Then
Private Declare PtrSafe Function Wow64DisableWow64FsRedirection Lib "kernel32" ( _
    ByRef OldValue As Long) As Long
Private Declare PtrSafe Function Wow64RevertWow64FsRedirection Lib "kernel32" ( _
    ByVal OldValue As Long) As Long


Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" ( _
    ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" ( _
    ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function IsWow64Process Lib "kernel32" ( _
    ByVal hProcess As LongPtr, ByRef Wow64Process As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
#Else
Private Declare Function Wow64DisableWow64FsRedirection Lib "kernel32" ( _
    ByRef OldValue As Long) As Long
Private Declare Function Wow64RevertWow64FsRedirection Lib "kernel32" ( _
    ByVal OldValue As Long) As Long


Private Declare Function GetModuleHandleA Lib "kernel32" ( _
    ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
    ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function IsWow64Process Lib "kernel32" ( _
    ByVal hProcess As Long, ByRef Wow64Process As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
#End If


Private Function DetectWow64() As Boolean
#If Win64 Then
  Dim Ret As LongPtr
#Else
  Dim Ret As Long
#End If
  If GetProcAddress(GetModuleHandleA("kernel32.dll"), "IsWow64Process") Then
    IsWow64Process GetCurrentProcess, Ret
    DetectWow64 = (Ret <> 0)
  End If
End Function


Private Function Path2MyDocuments() As String
'  Const S_OK = 0
'  Const MAX_PATH = 260
'  Dim IIDL As ITEMIDLIST
'  If SHGetSpecialFolderLocation(0, 5, IIDL) = S_OK Then
'    Path2MyDocuments = Space$(MAX_PATH)
'    If SHGetPathFromIDList(IIDL.mkID.cb, Path2MyDocuments) Then
'      Path2MyDocuments = Left$(Path2MyDocuments, InStr(Path2MyDocuments, vbNullChar) - 1)
'    Else
'      Path2MyDocuments = ""
'    End If
'  End If
  Dim WSHShell As Object
  Set WSHShell = CreateObject("Wscript.Shell")
  Path2MyDocuments = WSHShell.SpecialFolders("MyDocuments")
End Function


Private Sub Class_Initialize()
  Set FoundDirs = New Collection
  Set FoundFiles = New Collection
  Set SortFiles = New Collection
  Set SortDirs = New Collection
  Set fso = CreateObject("Scripting.FileSystemObject")
  FileType = msoFileTypeOfficeFiles
  LastModified = msoLastModifiedAnyTime
  LookIn = Path2MyDocuments
  IsWow64 = DetectWow64
End Sub


Private Sub Class_Terminate()
  Set FoundDirs = Nothing
  Set FoundFiles = Nothing
  Set SortFiles = Nothing
  Set SortDirs = Nothing
  Set fso = Nothing
End Sub


Public Sub NewSearch()
  FileName = ""
  LookIn = Path2MyDocuments
  FileType = msoFileTypeOfficeFiles
  LastModified = msoLastModifiedAnyTime
  SearchSubFolders = False
  ClearCollections
End Sub


Private Sub ClearCollections()
  If FoundFiles.Count > 0 Then
    Set FoundFiles = Nothing
    Set FoundFiles = New Collection
    Set SortFiles = Nothing
    Set SortFiles = New Collection
  End If
  If FoundDirs.Count > 0 Then
    Set FoundDirs = Nothing
    Set FoundDirs = New Collection
    Set SortDirs = Nothing
    Set SortDirs = New Collection
  End If
End Sub


Property Let FileName(Value As Variant)
  If IsArray(Value) Then
    fsFileName = Value
  Else
    fsFileName = Array(Value)
  End If
  fsFileType = 0
End Property


Property Get FileName() As Variant
  FileName = Join(fsFileName, ", ")
End Property


Property Let FileType(Value As msoFileType)
  fsFileType = Value
#If UseNewOfficeFileExtensions Then
  Select Case Value
    Case msoFileTypeAllFiles
      fsFileName = Array("*.*")
    Case msoFileTypeOfficeFiles
      fsFileName = Array( _
        "*.doc", "*.docm", "*.docx", "*.dot", "*.dotm", "*.dotx", _
        "*.htm", "*.html", _
        "*.mdb", "*.mdbm", "*.mdbx", "*.mpd", "*.mpdm", "*.mpdx", _
        "*.obd", "*.obdm", "*.obdx", "*.obt", "*.obtm", "*.obtx", _
        "*.pot", "*.potm", "*.potx", "*.pps", "*.ppsm", "*.ppsx", "*.ppt", "*.pptm", "*.pptx", _
        "*.xls", "*.xlsm", "*.xlsx", "*.xlt", "*.xltm", "*.xltx", "*.xlsb")
    Case msoFileTypeWordDocuments
      fsFileName = Array("*.doc", "*.docm", "*.docx", "*.htm", "*.html")
    Case msoFileTypeExcelWorkbooks
      fsFileName = Array("*.xls", "*.xlsm", "*.xlsx", "*.xlsb")
    Case msoFileTypePowerPointPresentations
      fsFileName = Array("*.pps", "*.ppsm", "*.ppsx", "*.ppt", "*.pptm", "*.pptx")
    Case msoFileTypeBinders
      fsFileName = Array("*.obd", "*.obdm", "*.obdx")
    Case msoFileTypeDatabases
      fsFileName = Array("*.mdb", "*.mdbm", "*.mdbx", "*.mpd", "*.mpdm", "*.mpdx")
    Case msoFileTypeTemplates
      fsFileName = Array( _
        "*.dot", "*.dotm", "*.dotx", _
        "*.obt", "*.obtm", "*.obtx", _
        "*.pot", "*.potm", "*.potx", _
        "*.xlt", "*.xltm", "*.xltx")
    Case Else
      fsFileType = 0
      fsFileName = Array("*.*")
  End Select
#Else
  Select Case Value
    Case msoFileTypeAllFiles
      fsFileName = Array("*.*")
    Case msoFileTypeOfficeFiles
      fsFileName = Array("*.doc", "*.dot", "*.htm", "*.html", "*.mdb", "*.mpd", "*.obd", "*.obt", _
        "*.pot", "*.pps", "*.ppt", "*.xls", "*.xlt")
    Case msoFileTypeWordDocuments
      fsFileName = Array("*.doc", "*.htm", "*.html")
    Case msoFileTypeExcelWorkbooks
      fsFileName = Array("*.xls")
    Case msoFileTypePowerPointPresentations
      fsFileName = Array("*.pps", "*.ppt")
    Case msoFileTypeBinders
      fsFileName = Array("*.obd")
    Case msoFileTypeDatabases
      fsFileName = Array("*.mdb", "*.mpd")
    Case msoFileTypeTemplates
      fsFileName = Array("*.dot", "*.obt", "*.pot", "*.xlt")
    Case Else
      fsFileType = 0
      fsFileName = Array("*.*")
  End Select
#End If
End Property


Property Get FileType() As msoFileType
  FileType = fsFileType
End Property


Property Let LastModified(Value As msoLastModified)
  If Value >= 1 And Value <= 7 Then
    fsLastModified = Value
  Else
    fsLastModified = msoLastModifiedAnyTime
  End If
End Property


Property Get LastModified() As msoLastModified
  LastModified = fsLastModified
End Property


Property Let LookIn(ByVal Value As String)
  fsLookIn = fso.BuildPath(fso.GetAbsolutePathName(Value), "\")
End Property


Property Get LookIn() As String
  LookIn = fsLookIn
End Property


Private Function MakeDecimal(ByVal Lo As Long, ByVal Hi As Long, _
    Optional ByVal wEx As Long = 0, _
    Optional Minus As Boolean = False) As Variant
  If Minus Then MakeDecimal = CDec(-1) Else MakeDecimal = CDec(1)
  CopyMemory ByVal VarPtr(MakeDecimal) + 8, Lo, 4
  CopyMemory ByVal VarPtr(MakeDecimal) + 12, Hi, 4
  If wEx <> 0 Then CopyMemory ByVal VarPtr(MakeDecimal) + 4, Lo, 4
End Function


Private Function FirstWeek(ByVal Datum As Date) As Date
  'Liefert den 1. Tag der Woche in dem Datum liegt
  FirstWeek = Datum - Weekday(Datum, vbUseSystemDayOfWeek) + 1
End Function


Private Sub SearchPrim(ByVal Path As String)
#If Win64 Then
  Dim hFindFile As LongPtr
#Else
  Dim hFindFile As Long
#End If
  Dim hFoundFile As WIN32_FIND_DATA
  Dim FName As String
  Dim STime As SYSTEMTIME
  Dim FTime As Date, ETime As Date, LTime As Date
  Dim CTime As Date, MTime As Date, ATime As Date
  Dim i As Integer, j As Long
  Dim AddIt As Boolean, Cancel As Boolean


  If fsLastModified <> msoLastModifiedAnyTime Then
    Select Case fsLastModified
      Case msoLastModifiedYesterday
        ETime = Date - 1
        LTime = Date - 1
      Case msoLastModifiedToday
        ETime = Date
        LTime = Date
      Case msoLastModifiedLastWeek
        ETime = FirstWeek(Date) - 7
        LTime = ETime + 6
      Case msoLastModifiedThisWeek
        ETime = FirstWeek(Date)
        LTime = ETime + 6
      Case msoLastModifiedLastMonth
        ETime = DateSerial(Year(Date), Month(Date) - 1, 1)
        LTime = DateSerial(Year(Date), Month(Date), 0)
      Case msoLastModifiedThisMonth
        ETime = DateSerial(Year(Date), Month(Date), 1)
        LTime = DateSerial(Year(Date), Month(Date) + 1, 0)
    End Select
  End If


  'Suche nach den Dateien
  For i = LBound(fsFileName) To UBound(fsFileName)
#If UniCode Then
    hFindFile = FindFirstFileEx(StrPtr(Path & fsFileName(i) & vbNullChar), _
      FindExInfoStandard&, VarPtr(hFoundFile), FindExSearchNameMatch&, 0&, 0&)
#Else
    hFindFile = FindFirstFileEx(Path & fsFileName(i) & vbNullChar, _
      FindExInfoStandard&, hFoundFile, FindExSearchNameMatch&, 0&, 0&)
#End If
    If hFindFile <> INVALID_HANDLE_VALUE Then
      Do
        With hFoundFile
          'Die Verzeichnisse ausschließen
          If (.dwFileAttributes And vbDirectory) = 0 Then
            If fsLastModified = msoLastModifiedAnyTime Then
              AddIt = True
            Else
              'Konvertiere Dateizeit zu Systemzeit
              FileTimeToSystemTime .ftLastWriteTime, STime
              'Generiere VBA-Datum
              With STime
                FTime = DateSerial(.wYear, .wMonth, .wDay)
              End With
              AddIt = FTime >= ETime And FTime <= LTime
            End If


            If AddIt Then
              j = InStr(.cFileName, vbNullChar) - 1
              FName = Mid$(.cFileName, 1, j)
              If j - InStrRev(FName, ".") > 3 Or Len(fsFileExt(i)) > 3 Then
                'Problem *.htm findet auch *.html
                AddIt = fso.GetExtensionName(FName) Like fsFileExt(i) And fso.GetBaseName(FName) Like fsFileBase(i)
              End If
            End If


#If FoundEvents Then
            If AddIt Then
              FileTimeToSystemTime .ftLastAccessTime, STime
              With STime
                ATime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
              End With
              FileTimeToSystemTime .ftLastWriteTime, STime
              With STime
                MTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
              End With
              FileTimeToSystemTime .ftCreationTime, STime
              With STime
                CTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
              End With
              RaiseEvent FoundFile(Path & FName, .dwFileAttributes, CTime, ATime, MTime, MakeDecimal(.nFileSizeLow, .nFileSizeHigh), AddIt)
            End If
#End If


            If AddIt Then
              FoundFiles.Add Path & FName


              'Sollen wir sortieren?
              Select Case SortFilesBy
                Case msoSortByFileName
                  'Pfad, dann Name
                  SortFiles.Add FName & Path
                Case msoSortByFileType
                  'Extension, dann Pfad, dann Name
                  SortFiles.Add fso.GetExtensionName(FName) & Path & FName
                Case msoSortByLastModified
                  'Konvertiere Dateizeit zu Systemzeit
                  FileTimeToSystemTime .ftLastWriteTime, STime
                  'Generiere VBA-Datum
                  With STime
                    FTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
                  End With
                  SortFiles.Add FTime
                Case msoSortBySize
                  SortFiles.Add MakeDecimal(.nFileSizeLow, .nFileSizeHigh)
              End Select
            End If
          Else
            If fsLastModified = msoLastModifiedAnyTime Then
              AddIt = True
            Else
              'Konvertiere Dateizeit zu Systemzeit
              FileTimeToSystemTime .ftLastWriteTime, STime
              'Generiere VBA-Datum
              With STime
                FTime = DateSerial(.wYear, .wMonth, .wDay)
              End With
              AddIt = FTime >= ETime And FTime <= LTime
            End If


            If AddIt Then
              'Problem Verzeichnisse "." und ".." ausschließen, aber alle anderen zulassen (.borland)
              AddIt = InStr(.cAlternate, vbNullChar) > 1
              If Not AddIt Then
                For j = 1 To Len(.cFileName)
                  Select Case Mid$(.cFileName, j, 1)
                    Case "."
                    Case vbNullChar
                      Exit For
                    Case Else
                      AddIt = True
                      Exit For
                  End Select
                Next
              End If
            End If


            If AddIt Then
              FName = Mid$(.cFileName, 1, InStr(.cFileName, vbNullChar) - 1)
              If InStr(FName, "?") > 0 Then
                'Problem Verzeichnisse mit ungültigen Zeichen "??sortierte Lesezeichen"
                FName = Mid$(.cAlternate, 1, InStr(.cAlternate, vbNullChar) - 1)
              End If
            End If


#If FoundEvents Then
            If AddIt Then
              FileTimeToSystemTime .ftLastAccessTime, STime
              With STime
                ATime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
              End With
              FileTimeToSystemTime .ftLastWriteTime, STime
              With STime
                MTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
              End With
              FileTimeToSystemTime .ftCreationTime, STime
              With STime
                CTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
              End With
              RaiseEvent FoundFolder(Path & FName, .dwFileAttributes, CTime, ATime, MTime, AddIt)
            End If
#End If


            If AddIt Then
              FoundDirs.Add Path & FName


              'Sollen wir sortieren?
              Select Case SortFilesBy
                Case msoSortByFileName
                  'Pfad
                  SortDirs.Add Path & FName
                Case msoSortByFileType
                  'Extension, dann Pfad, dann Name
                  SortDirs.Add fso.GetExtensionName(FName) & Path & FName
                Case msoSortByLastModified
                  'Konvertiere Dateizeit zu Systemzeit
                  FileTimeToSystemTime .ftLastWriteTime, STime
                  'Generiere VBA-Datum
                  With STime
                    FTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
                  End With
                  SortDirs.Add FTime
                Case msoSortBySize
                  SortDirs.Add MakeDecimal(.nFileSizeLow, .nFileSizeHigh)
              End Select
            End If
          End If
        End With
#If UniCode Then
      Loop Until FindNextFile(hFindFile, VarPtr(hFoundFile)) <> 1
#Else
    Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
#End If
    FindClose hFindFile
  End If
Next


If SearchSubFolders Then
  'Suche nach einem Verzeichnis
  'Problem "*." findet keine Verzeichnisse die einen Punkt enthalten!
#If UniCode Then
  hFindFile = FindFirstFileEx(StrPtr(Path & "*" & vbNullChar), _
    FindExInfoStandard&, VarPtr(hFoundFile), FindExSearchLimitToDirectories&, 0&, 0&)
#Else
  hFindFile = FindFirstFileEx(Path & "*" & vbNullChar, _
    FindExInfoStandard&, hFoundFile, FindExSearchLimitToDirectories&, 0&, 0&)
#End If
  If hFindFile <> INVALID_HANDLE_VALUE Then
    Do
      With hFoundFile
        If (.dwFileAttributes And vbDirectory) > 0 Then
          'Problem Verzeichnisse "." und ".." ausschließen, aber alle anderen zulassen (.borland)
          AddIt = InStr(.cAlternate, vbNullChar) > 1
          If Not AddIt Then
            'AddIt = Left$(.cFileName, 1) <> "."
            For j = 1 To Len(.cFileName)
              Select Case Mid$(.cFileName, j, 1)
                Case "."
                Case vbNullChar
                  Exit For
                Case Else
                  AddIt = True
                  Exit For
              End Select
            Next
          End If


          If AddIt Then
            FName = Mid$(.cFileName, 1, InStr(.cFileName, vbNullChar) - 1)
            If InStr(FName, "?") > 0 Then
              'Problem Verzeichnisse mit ungültigen Zeichen "??sortierte Lesezeichen"
              FName = Mid$(.cAlternate, 1, InStr(.cAlternate, vbNullChar) - 1)
            End If
            Cancel = False
            RaiseEvent BeforeSearchFolder(Path & FName, Cancel)
            'Starte rekursive Suche
            If Not Cancel Then SearchPrim Path & FName & "\"
          End If
        End If
      End With
#If UniCode Then
    Loop Until FindNextFile(hFindFile, VarPtr(hFoundFile)) <> 1
#Else
  Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
#End If
  FindClose hFindFile
End If
End If
End Sub


Private Sub QuickSortCollection(ByRef Liste As Collection, ByRef Data As Collection, _
    Optional ByVal Compare As VbCompareMethod = vbDatabaseCompare, _
    Optional ByVal SortOrder As msoSortOrder = msoSortOrderAscending)
  'Sortiert eine Collection mit beliebigen Werten, führt eine zweite Collection parallel mit
  Const QTHRESH As Long = 9
  Dim i As Long, j As Long, C As Integer, Ci As Integer, Cj As Integer
  Dim Pivot, Temp
  Dim DArr(), LArr()
  Dim DoResume As Boolean
  Dim Stack(1 To 64) As Long
  Dim StackPtr As Long
  Dim Start As Long, Ende As Long


  'Wir brauchen mind. 2 Elemente
  If Liste.Count < 2 Then Exit Sub


  'Daten aus der Collection in ein Array übertragen
  ReDim LArr(1 To Liste.Count)
  ReDim DArr(1 To Liste.Count)
  i = 0
  For Each Temp In Liste
    i = i + 1
    LArr(i) = Temp
  Next
  i = 0
  For Each Temp In Data
    i = i + 1
    DArr(i) = Temp
  Next


  Start = 1
  Ende = UBound(LArr)
  If SortOrder = msoSortOrderAscending Then C = 1 Else C = -1
  Ci = 1


  Stack(StackPtr + 1) = Start
  Stack(StackPtr + 2) = Ende
  StackPtr = StackPtr + 2


  Do
    StackPtr = StackPtr - 2
    Start = Stack(StackPtr + 1)
    Ende = Stack(StackPtr + 2)


    If Ende - Start < QTHRESH Then
      'Insertionsort
      Select Case Compare
        Case vbDatabaseCompare
          'Zahlen sortieren
          If SortOrder = msoSortOrderAscending Then
            For j = Start + 1 To Ende
              Pivot = LArr(j)
              Temp = DArr(j)
              For i = j - 1 To Start Step -1
                If LArr(i) <= Pivot Then Exit For
                LArr(i + 1) = LArr(i)
                DArr(i + 1) = DArr(i)
              Next
              LArr(i + 1) = Pivot
              DArr(i + 1) = Temp
            Next
          Else
            For j = Start + 1 To Ende
              Pivot = LArr(j)
              Temp = DArr(j)
              For i = j - 1 To Start Step -1
                If LArr(i) >= Pivot Then Exit For
                LArr(i + 1) = LArr(i)
                DArr(i + 1) = DArr(i)
              Next
              LArr(i + 1) = Pivot
              DArr(i + 1) = Temp
            Next
          End If


        Case vbTextCompare
          'Texte sortieren => MatchCase:=False
          For j = Start + 1 To Ende
            Pivot = LArr(j)
            Temp = DArr(j)
            For i = j - 1 To Start Step -1
              Ci = StrComp(LArr(i), Pivot, Compare)
              If Ci <> C Then Exit For
              LArr(i + 1) = LArr(i)
              DArr(i + 1) = DArr(i)
            Next
            LArr(i + 1) = Pivot
            DArr(i + 1) = Temp
          Next
      End Select
    Else
      'QuickSort
      i = Start: j = Ende
      Pivot = LArr((Start + Ende) \ 2)
      Do
        Select Case Compare
          Case vbDatabaseCompare
            'Zahlen sortieren
            If SortOrder = msoSortOrderAscending Then
              Do While (LArr(i) < Pivot): i = i + 1: Loop
              Do While (LArr(j) > Pivot): j = j - 1: Loop
            Else
              Do While (LArr(i) > Pivot): i = i + 1: Loop
              Do While (LArr(j) < Pivot): j = j - 1: Loop
            End If


          Case vbTextCompare
            'Texte sortieren => MatchCase:=False
            Ci = StrComp(LArr(i), Pivot, Compare)
            Do While (Ci = -C)
              i = i + 1
              Ci = StrComp(LArr(i), Pivot, Compare)
            Loop
            Cj = StrComp(LArr(j), Pivot, Compare)
            Do While (Cj = C)
              j = j - 1
              Cj = StrComp(LArr(j), Pivot, Compare)
            Loop
        End Select


        If i <= j Then
          If i < j And Not (Ci = 0 And Cj = 0) Then
            Temp = DArr(i)
            DArr(i) = DArr(j)
            DArr(j) = Temp
            Temp = LArr(i)
            LArr(i) = LArr(j)
            LArr(j) = Temp
          End If
          i = i + 1: j = j - 1
        End If
      Loop Until i > j


      If (Start < j) Then
        'QuickSort LArr, Start, j, Compare, SortOrder
        Stack(StackPtr + 1) = Start
        Stack(StackPtr + 2) = j
        StackPtr = StackPtr + 2
      End If
      If (i < Ende) Then
        'QuickSort LArr, i, Ende, Compare, SortOrder
        Stack(StackPtr + 1) = i
        Stack(StackPtr + 2) = Ende
        StackPtr = StackPtr + 2
      End If
    End If
  Loop Until StackPtr = 0


  'Collection neu aufbauen
  Set Data = Nothing
  Set Data = New Collection
  For i = 1 To UBound(DArr)
    Data.Add DArr(i)
  Next
End Sub


Public Function Execute( _
    Optional SortBy As msoSortBy = 0, _
    Optional SortOrder As msoSortOrder = msoSortOrderAscending, _
    Optional AlwaysAccurate As Boolean = True) As Long
  'Beginnt die Suche nach den angegebenen Dateien.
  'SortBy:
  '  Die für die Sortierung der zurückgegebenen Dateien verwendete Methode. Dies kann eine der _
    folgenden MsoSortBy- Konstanten sein: msoSortbyFileName, msoSortbyFileType, _
    msoSortbyLastModified oder msoSortbySize. Ist SortBy = 0 wird nicht sortiert
  'SortOrder:
  '  Die Reihenfolge, in der die zurückgegebenen Dateien sortiert werden sollen. Dies kann eine _
    der folgenden MsoSortOrder-Konstanten sein: msoSortOrderAscending oder msoSortOrderDescending.
  'AlwaysAccurate:
  '  Ohne Funktion, nur aus Kompatiblitätsgründen


  Dim i As Integer
  Dim OldValue64Bit As Long


  ReDim fsFileExt(LBound(fsFileName) To UBound(fsFileName))
  ReDim fsFileBase(LBound(fsFileName) To UBound(fsFileName))
  For i = LBound(fsFileName) To UBound(fsFileName)
    fsFileExt(i) = fso.GetExtensionName(fsFileName(i))
    fsFileBase(i) = fso.GetBaseName(fsFileName(i))
  Next


  ClearCollections
  SortFilesBy = SortBy


  If IsWow64 Then
    If Wow64DisableWow64FsRedirection(OldValue64Bit) = 0 Then IsWow64 = False
  End If
  SearchPrim fsLookIn
  If IsWow64 Then Wow64RevertWow64FsRedirection OldValue64Bit
  Execute = FoundFiles.Count
  Select Case SortBy
    Case msoSortByFileName, msoSortByFileType
      QuickSortCollection SortFiles, FoundFiles, vbTextCompare, SortOrder
      QuickSortCollection SortDirs, FoundDirs, vbTextCompare, SortOrder
    Case msoSortByLastModified, msoSortBySize
      QuickSortCollection SortFiles, FoundFiles, vbDatabaseCompare, SortOrder
      QuickSortCollection SortDirs, FoundDirs, vbDatabaseCompare, SortOrder
  End Select
End Function

[branston]

Hi Paul

Played with this some more and nearly got it working. Issue now is first 10 files are being named properly... however the 11th File in the Folder is being labelled with the 100th file in the excel list. After that everything is out of sync. Assuming this is something to do with how Excel reads 10 and 100 etc.?

[Paul_Hossler]

Possilble technique that ou can integrate into your code

Pretty brute force and simplistic

Capture.JPG

Option Explicit


Sub Renumber()
    Dim i As Long, j As Long
    Dim A() As String
    Dim r As Range
    Dim s As String, s2 As String
    
    Set r = ActiveSheet.Cells(1, 1).CurrentRegion
    
    ReDim A(1 To r.Rows.Count, 1 To 2)
        
    For i = 1 To r.Rows.Count
        s = UCase(r.Cells(i, 1).Text)
        A(i, 1) = r.Cells(i, 1).Text
        
        If s Like "*###.PDF" Then
            A(i, 2) = Right(s, 7)
        ElseIf s Like "*##.PDF" Then
            A(i, 2) = "0" & Right(s, 6)
        ElseIf s Like "*#.PDF" Then
            A(i, 2) = "00" & Right(s, 5)
        End If
    Next i
    
    'simple bubble sort - could put onto worksheet and sort
    For i = LBound(A) To UBound(A, 1) - 1
        For j = i + 1 To UBound(A, 1)
            If A(i, 2) > A(j, 2) Then
                s = A(i, 1)
                s2 = A(i, 2)
                A(i, 1) = A(j, 1)
                A(i, 2) = A(j, 2)
                A(j, 1) = s
                A(j, 2) = s2
            End If
        Next j
    Next i
    
    'put back - replace with
    For i = LBound(A, 1) To UBound(A, 1)
        ActiveSheet.Cells(i, 4).Value = A(i, 1)
    Next i
End Sub

[branston]

Thanks Paul.

Issue however is in the pics attached. File 11.pdf in the folder is re-named with 100.Pears.pdf when it should be 11.Apple.pdf

Sorry if not explained things properly.

[Paul_Hossler]

You asked

E.g. This is the order in my folder
File1 in my folder is Trees8.pdf
File2 in my folder is Leaves9.pdf
File3 in my folder is Bears10.pdf
File4 in my folder is Sky11.pdf
File5 in my folder is Water12.pdf and so on

However the output listed in Column A in Excel is :

Bears10.pdf
Sky11.pdf
Water12.pdf
Trees8.pdf
Leaves9.pdf

Where did naming like "11.Apple.pdf" come from???


If that's what you want, there's no need to sort in my first sub, but a simple user defined function should work to add a prefix number before you copy to your worksheet.


You'll probably have to accept a 3 number prefix


Capture.JPG

Option Explicit


Sub test()
    Dim r As Range
    Dim i As Long
    
    Set r = ActiveSheet.Cells(1, 1).CurrentRegion
    
    For i = 1 To r.Rows.Count
        ActiveSheet.Cells(i, 4).Value = Renumber(ActiveSheet.Cells(i, 1).Value)
    Next i


End Sub




Function Renumber(FileIn As String) As String
    Dim s As String, n As String, f As String, uc As String, noext As String
    
    uc = UCase(FileIn)
    noext = Left(FileIn, Len(FileIn) - 4)
        
        
    If uc Like "*###.PDF" Then
        n = Right(noext, 3)
        f = Left(noext, Len(noext) - 3)
    ElseIf uc Like "*##.PDF" Then
        n = Right(noext, 2)
        f = Left(noext, Len(noext) - 2)
    ElseIf uc Like "*#.PDF" Then
        n = Right(noext, 1)
        f = Left(noext, Len(noext) - 1)
    End If
    
    Renumber = Format(n, "000") & "." & f & ".pdf"
End Function

[p45cal]

Try the following (you don't need the FileSearch Class):

Sub blah()
Set fso = CreateObject("Scripting.FileSystemObject")
myPath = ThisWorkbook.Path & Application.PathSeparator
For Each R In Range("A1", Range("A" & Rows.Count).End(xlUp))
  Z = R.Value    '"06.Elephants"
  dot = InStr(Z, ".")    '3
  q = Left(Z, dot - 1)    '"06"
  OldName = "File" & q & ".pdf"    '"File06.pdf"
  NewName = Z & ".pdf"    '"06.Elephants.pdf"
  If fso.fileexists(myPath & OldName) Then Name fso.getfile(myPath & OldName) As myPath & NewName
Next R
End Sub

This goes through the names in column A of the active sheet

• Takes everything to the left of the first dot in those names (including leading zeroes) and
• uses it to construct a filename to look for in the same folder as the workbook is in of the ilk: File06.pdf then
• if it finds one renames it to what's in the cell in column A with .pdf tacked on..

Bear in mind you said "files are just called File1.pdf, File2.pdf etc." whereas your picture suggests files are called File01.pdf, File02.pdf etc.

ps.the above can be shortened to:

Sub blah2()
Set fso = CreateObject("Scripting.FileSystemObject")
myPath = ThisWorkbook.Path & Application.PathSeparator
For Each R In Range("A1", Range("A" & Rows.Count).End(xlUp))
  OldName = myPath & "File" & Left(R.Value, InStr(R.Value, ".") - 1) & ".pdf"
  If fso.fileexists(OldName) Then Name fso.getfile(OldName) As myPath & R.Value & ".pdf"
Next R
End Sub

[SamT]

That's because onezerozero comes after onezero but before oneone. If you had continued, you would have noticed that oneonezero comes before onetwo, and onetwozero before onethree

First use a File Rename program to rename all the files in the folder by inserting an underscore before the dot, then running your current code. File11_.pdf comes before File100_.pdf

[branston]

Hi guys

Manage to get it working in the end using a combination of suggestions above - so thank you.

However I did keep hitting a stumbling block until I realised that I had to use

    .Execute msoSortByFileName

and not

    .Execute msoSortByFileName, msoSortOrderAscending

which kept renaming the files in the wrong order despite the file naming being correct.

Thanks again all.

[snb]

Sub M_snb()
  Set fs = CreateObject("scripting.filesystemobject").getfolder("G:\pdf\").Files
    
  With CreateObject("ADODB.recordset")
    .Fields.Append "name", 129, 120
    .Fields.Append "number", 4
    .Open
        
    For Each it In fs
      .AddNew
      .Fields("name") = it
      .Fields("number") = Application.Max(Array(Val(Right(it, 8)), Val(Right(it, 7)), Val(Right(it, 6))))
      .Update
    Next
        
    .Sort = "number"
    MsgBox Join(Filter(Split(vbCr & Replace(.getstring, vbCr, vbTab & vbCr), vbTab), "."), "")
  End With
End Sub

[Danpeterson]

If you’re currently struggling with this issue, we might be of help. Below you have a collection of methods that have enabled users in a similar situation to resolve the issue. Please follow each potential fix in order until you encounter a method that fixes the “Destination Path Too Long” error.

[Aussiebear]

If you’re currently struggling with this issue, we might be of help. Below you have a collection of methods that have enabled users in a similar situation to resolve the issue. Please follow each potential fix in order until you encounter a method that fixes the “Destination Path Too Long” error.

Are you sure you posted this is the correct thread?

[Paul_Hossler]

Are you sure you posted this is the correct thread?

FWIW, I took that as spam to a 10 month old post and ignored it

If there actually had been a link to a web site as alluded to in in the post

Below you have a collection of methods ...

I'd have spam deleted it

[Aussiebear]

Thanks Paul, it was borderline for deletion to me as it appears too irrelevant to the thread but I must be getting soft in my old age

[Bob Phillips]

Thanks Paul, it was borderline for deletion to me as it appears too irrelevant to the thread but I must be getting soft in my old age

Poster's first post, irrelevant text, it's spam and I would have deleted in an instance if I had been following this thread. No softening here!