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/office/vba/language/reference/user-interface-help/filedatetime-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

27959





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


27965




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. :clap:

[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!