PDA

View Full Version : vba excel dir loosing file name in looping



vocedicore
06-10-2019, 05:36 AM
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.


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

p45cal
06-10-2019, 06:21 AM
Perhaps:
Pool = "C:\Users\chris\Documents\TEST\"
instead of:
Pool = "C:\Users\chris\Documents\TEST"
?
Likewise for FDPath?

vocedicore
06-10-2019, 08:18 PM
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) & ""

Artik
06-11-2019, 01:16 AM
With such a procedure construction, you can not use the following line in the loop, because Dir function is silly. ;)

REFfolder = Dir(FDpath & "*" & REF, vbDirectory) & ""
https://docs.microsoft.com/office/vba/language/reference/user-interface-help/dir-function
In the function instructions we read:
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

Leith Ross
06-13-2019, 10:04 AM
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.


' 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



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