vba excel dir loosing file name in looping

Dear All,

I'm trying to move file to proper folder which has same key word.
the dir function loose looping file name.
Please let me know for best result.

Code:

---

Public Sub DOCsort()
Dim REF As String, FDpath As String, Pool As String, REFfolder As String, DOCpath As String, LoopFile As String
Pool = "C:\Users\chris\Documents\TEST"
FDpath = "C:\Users\chris\Documents\TEST\FD"


LoopFile = Dir(Pool & "*"):
'find matching file
Do While LoopFile <> ""
    REF = REFextractor(LoopFile)
    Select Case Len(REF)
    Case Is > 5 'complete number
       
        REFfolder = Dir(FDpath & "*" & REF, vbDirectory) & ""
        Name Pool & LoopFile As FDpath & REFfolder & LoopFile
     
    End Select
   
    'Name Pool & LoopFile As FDpath & REFfolder & LoopFile
    LoopFile = Dir
Loop
End Sub


Public Function REFextractor(str)
Dim x As Integer, ext As String, txt As String


If InStr(Right(str, 5), ".") Then
    ext = Right(Right(str, 5), Len(Right(str, 5)) - InStr(Right(str, 5), ".") + 1)
    txt = Replace(str, ext, "")
End If
txt = Replace(Replace(Replace(txt, "_", " "), "-", " "), ".", " ")
REFextractor = Trim(Right(txt, Len(txt) - InStr(txt, " ")))
End Function

---

Perhaps:
Pool = "C:\Users\chris\Documents\TEST\"
instead of:
Pool = "C:\Users\chris\Documents\TEST"
?
Likewise for FDPath?

I tried with TEST\, but did't work.
it seem like it changing dir after below one.
if I add LoopFile = Dir before below code can get right one, but after this loopfile get blank.
How can I run dir for file and folder?
HBLfolder = Dir(FDpath & "*" & HBL, vbDirectory) & ""

With such a procedure construction, you can not use the following line in the loop, because Dir function is silly. ;)

Code:

---

REFfolder = Dir(FDpath & "*" & REF, vbDirectory) & ""

---

https://docs.microsoft.com/office/vb...p/dir-function
In the function instructions we read:

Quote:

---

You can change to a new pathname without retrieving all of the file names that match the current pathname. However, you can't call the Dir function recursively. Calling Dir with the vbDirectory attribute does not continually return subdirectories.

---

To solve your problem, use the FileSystemObject from the Microsoft Scripting Runtime library.

Artik

Hello voedicore,

You may this helpful. I wrote this macro to return all matching files to a 1-d array. The full path of each matching file is saved to the array. This uses only the DIR function and no other libraries so it can be used with any version of VBA. This macro is flexible. You can control the folder depth of the search as well as the file pattern you want to match. See the Summary notes in the comments above the macro code for more information.

Macro Code
Copy the code and paste it into a Standard VBA Module in your workbook.

Code:

---

' Written:  June 13, 2019
' Author:  Leith Ross
'
' Summary:  Lists all files in the specified folder with the option to recurse all the subfolders
'          or to a specific depth. The default is zero (0) which lists only the files in the specified
'          folder. Negative one (-1) lists all files in all folders. A positive integer will not recurse
'          folders deeper than it's value.
'
'          The matching files full paths are saved to the 1-D array FileList. The first element's index
'          is zero. The last element is always empty. Checking if the zero element is empty will tell you
'          if any files were found. When looping through FileList, start with zero to the UBound(FileList) - 1.
'
'          The second option is file matching which is not case sensitive. The default is all files *.*
'          The matching accepts standard wildcard characters: asterisk *, question mark ? and hashtag #
'
'          Since no other scripting libraries are needed this method, it works with all versions of VBA.


Private FileList    As Variant


Sub ListFiles(ByVal Folder_Path As String, Optional ByVal RecurseDepth As Long, Optional ByVal Filter As String)


    Dim FileName    As String
    Dim FilePath    As String
    Dim Filespec    As String
    Dim row        As Long
    Dim SubFolder  As Variant
    Dim SubFolders  As Collection
       
        If Filter = "" Then Filter = "*.*" Else Filter = LCase(Filter)
       
        If SubFolders Is Nothing Then Set SubFolders = New Collection
       
        FilePath = IIf(Right(Folder_Path, 1) <> "\", Folder_Path & "\", Folder_Path)
       
        On Error Resume Next
            FileName = Dir(FilePath & "*.*", vbDirectory)
            If Err <> 0 Then
                GoTo NextFolder
            End If
        On Error GoTo 0
       
        While FileName <> ""
            DoEvents
            Filespec = FilePath & FileName
           
            On Error Resume Next
                If (GetAttr(Filespec) And vbDirectory) = vbDirectory Then
                    If FileName <> "." And FileName <> ".." And RecurseDepth <> 0 Then
                        SubFolders.Add Filespec, Filespec
                    End If
                Else
                    If LCase(FileName) Like Filter Then
                        row = UBound(FileList)
                        FileList(row) = Filespec
                        ReDim Preserve FileList(row + 1)
                    End If
                End If
            On Error GoTo 0
           
            FileName = Dir()
        Wend
       
NextFolder:
        On Error GoTo 0
       
        If RecurseDepth <> 0 Then
            For Each SubFolder In SubFolders
                SubFolders.Remove 1
                Call ListFiles(SubFolder, RecurseDepth - 1, Filter)
            Next SubFolder
        End If
       
End Sub

---

Example of using the Macro

Code:

---

Sub ListFilesTest()


    Dim FileCnt    As Long
    Dim FilePath    As String
    Dim MyPath      As String


        ' // Always do this before running the macro.
        ReDim FileList(0)
       
        ' // Change this to folder you want to search.
        MyPath = "C:\Test"
       
        ' // Get all text files in main folder and 1 level deep in subfolders.
        ListFiles MyPath, 1, "*.txt"
   
        ' // Number of files found.
        FileCnt = UBound(FileList)
       
        ' // If this element is an empty string then no files were found.
        FilePath = FileList(0)
       
End Sub

---