I need to do a code in VBA to find a file in a subdirectory.
With the code from 'brettdj' in this link I can find the file if I specify the full directory
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("\\A\B\C\D\")
While (file <> "")
If InStr(file, "701000034955") > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
I'm looking for a why to not to have to specify the full directory.
I tried the code in this link, but I get a 'type mistmatch' error message in the last line
Sub Find_Files()
f = "\\A\B\"
ibox = "701000034955"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets("Sheet1").[A1].Resize(UBound(sn) + 1) = Application.Transpose(sn) ' I get an error message in this line
End Sub
Any ideas on why the code above is not working and if there is a better solution to search in subfolders for a file?
your second code differs from the first one in that this latter searches for any file in given folder (and subfolders) whose name is exactly "701000034955" while the former searches for file whose name contains that string
hence I guess you just have to use some wildchars
ibox = "*701000034955*"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & Application.PathSeparator & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets("Sheet1").[A1].Resize(UBound(sn)) = Application.Transpose(sn)
note the resizing is UBound(sn) instead of UBound(sn) + 1 since there's one endingvbCrlf generating an empty entry in the last position of sn
For the bottom one don't forget to fully qualify the file name with its extension and consider using Path separator to concatenate. For example:
Sub Find_Files()
Dim f As String
f = ThisWorkbook.Path
ibox = "701000034955.xlsb"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & Application.PathSeparator & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets("Sheet1").[A1].Resize(UBound(sn) + 1) = Application.Transpose(sn)
End Sub
Related
Please go through my code, correct me where I am wrong, files are not moving from folder to folder.
Option Explicit
Sub MoveFiles()
Dim FSO As Object
Dim FromDir As String
Dim ToDir As String
Dim FExtension As String
Dim Fnames As String
FromDir = "C:\Users\B\Source Folder"
ToDir = "C:\Users\B\Destination Folder"
FExtension = "*.*"
Fnames = Dir(FromDir & FExtension)
If Len(Fnames) = 0 Then
MsgBox "No files or Files already moved" & FromDir
Exit Sub
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Source:=FromDir & FExtension, Destination:=ToDir
End Sub
Problem
You are missing a \ at the end of your FromDir which will separate the path from your filenames.
For your info: & is not really combining path and filename, but just concatenating two strings, so it never adds the \ itself.
Correction possibility 1
You can add it to the definition of FromDir:
FromDir = "C:\Users\B\Source Folder\"
Correction possibility 2
Add it to these lines of code dynamically:
Fnames = Dir(FromDir & "\" & FExtension)
FSO.MoveFile Source:=FromDir & "\" & FExtension, Destination:=ToDir
Another remark
You should also separate FromDir from the error text, like this:
MsgBox "No files or Files already moved: " & FromDir
Call MOVEDFFILES("C:\TEMP\MAIN FOLDER\INVOICES\COUNTRY\Invoices\" & SEASON & " DF Invoices\", "C:\TEMP\MAIN FOLDER\INVOICES\COUNTRY\Invoices\" & SEASON & " DF Invoices\Imported\")
I have created the above code to call the below code and move files if they don't exist in the new folder, and delete them in the original folder if they do. however whilst I can use Name OldLocation & MyFile As NewLocation & MyFile to move the files, they dissapear when trying to use the code below. This code works else where for a different file path, the only difference is using *.csv as MyFile, could this cause an issue?
Private Sub MOVEDFFILES(OldLocation As Variant, NewLocation As Variant)
'Makes the file path if not there
If Dir(NewLocation, vbDirectory) = "" Then
MkDir NewLocation
End If
'Moves the files from one location to another
MyFile = Dir(OldLocation & "*.csv")
Do Until MyFile = ""
If Not NewLocation & MyFile > 0 Then
Name OldLocation & MyFile As NewLocation & MyFile
Else
Kill OldLocation & MyFile
End If
MyFile = Dir
Loop
End Sub
The problem is that your check if the file exists in the new location is wrong.
Easiest way to check it would be to issue a Dir-command, but that would break your loop. You can have only one Dir command open, issuing a Dir within the loop to check if the file exists in the new location would cause the command MyFile = Dir fail to check for the next file in the old location.
Turns out that you don't have to do the check at all: Simply issue both, the Name and the Kill command. Trick is to ignore any errors. If the file doesn't exists in the new location, the Name would move it and the Kill doesn't have to delete anything because the file is already gone.. If the file already exists in the new location, the Name will fail and the Kill will do it's job...
So, this is one of the really few situations to use the infamous On Error Resume Next:
f = Dir(OldLocation & "*.csv")
Do Until f = ""
On Error Resume Next
Name OldLocation & f As NewLocation & f
Kill OldLocation & f
On Error GoTo 0
f = Dir
Loop
I am using the below code to get the last modified datetime of a file from a shared folder.
Public Sub CountTextFilesInFolder()
FolderPath = "\\SVTickets\"
Count = 0
If Right(FolderPath, 1) = "\" Then
SourcePath = FolderPath
SourcPath = SourcePath & "*.txt"
ElseIf Right(FolderPath, 1) <> "\" Then
SourcePath = FolderPath
SourcPath = SourcePath & "*.txt"
End If
FileName = Dir(SourcPath)
Do While FileName <> ""
DateTim = FileDateTime(SourcePath & FileName)
If Format(DateTim, "YYYYMMDD") = Format(Date, "YYYYMMDD") Then
Count = Count + 1
End If
FileName = Dir()
Loop
End Sub
Could someone suggest how can be improved the performance of the above code.
There are 7k files inside that folder and taking hours to run.
Thanks in Advance.
Command line? The following writes out the details to the immediate window.
C:\Users\User\Desktop\TestFolder is the folder to loop over which you can extract out into a variable. If there are a lot of files you wouldn't debug.print but could write array direct out to sheet.
Option Explicit
Public Sub Find_Files()
Dim fileDetails() As String
fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c cd C:\Users\User\Desktop\TestFolder && for /f %a in ('dir /b *.txt') do #echo %a %~ta").stdout.readall, vbCrLf)
Dim i As Long
For i = LBound(fileDetails) To UBound(fileDetails)
If Not IsEmpty(fileDetails(i)) Then Debug.Print fileDetails(i)
Next i
End Sub
Messy version for network drive:
Option Explicit
Public Sub Find_Files()
Dim folderpath As String
Dim drive As String
folderpath = "\Folder1\Folder2\TestFolder"
drive = "R:"
Dim fileDetails() As String
fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c cd /D " & drive & " && cd " & folderpath & " && for /f %a in ('dir /b *.txt') do #echo %a %~ta").stdout.readall, vbCrLf)
Dim i As Long
For i = LBound(fileDetails) To UBound(fileDetails)
If Not IsEmpty(fileDetails(i)) Then Debug.Print fileDetails(i)
Next i
End Sub
I am wondering if anyone can help me edit this VBA script so that it not only moves the files (this part is complete by the way), but it also appends a 0 to the front of the filename (this part has not been started.
So, if the original filename is 123456789.tif, then the resultant will be 0123456789.tif.
Thank you!
Sub MoveIfFilelength()
'This script moves files from a source directory to a final directory based on the number of characters in the filename (e.g., 14, as below)
Dim srcDir As String
Dim dstDir As String
Dim f As String
srcDir = "S:\\" 'Input source directory
dstDir = "S:\\" 'Input destination directory
f = Dir(srcDir)
Do While f <> ""
If Len(f) = 13 Then Name srcDir & "\" & f As dstDir & "\" & f 'Input filename length
f = Dir()
Loop
End Sub
Name .. As is the move operation which is semantically a rename already, so specify the new name as "\0" & f:
If Len(f) = 13 Then Name srcDir & "\" & f As dstDir & "\0" & f
I have this code which finds file names(along with file paths) based on search string.This code works fine in finding single files. I would like this macro to find multiple files and get their names displayed separated using a comma.
Function FindFiles(path As String, SearchStr As String)
Dim FileName As String ' Walking filename variable.
Dim DirName As String ' SubDirectory Name.
Dim dirNames() As String ' Buffer for directory name entries.
Dim nDir As Integer ' Number of directories in this path.
Dim i As Integer ' For-loop counter.
Dim Name As String
Dim Annex As String
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
' Search for subdirectories.
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden Or vbArchive Or vbReadOnly _
Or vbSystem) ' Even if hidden, and so on.
Do While Len(DirName) > 0
' Ignore the current and encompassing directories.
If (DirName <> ".") And (DirName <> "..") Then
' Check for directory with bitwise comparison.
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
'List2.AddItem path & DirName ' Uncomment to list
End If ' directories.
sysFileERRCont:
End If
DirName = Dir() ' Get next subdirectory.
Loop
' Search through this directory and sum file sizes.
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly Or vbArchive)
'Sheet1.Range("C1").Value2 = path & "\" & FileName
While Len(FileName) <> 0
FindFiles = path & "\" & FileName
FileCount = FileCount + 1
' Load List box
' Sheet1.Range("A1").Value2 = path & FileName & vbTab & _
FileDateTime(path & FileName) ' Include Modified Date
FileName = Dir() ' Get next file.
Wend
' If there are sub-directories..
If nDir > 0 Then
' Recursively walk into them
For i = 0 To nDir - 1
FindFiles = path & "\" & FileName
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont ' Known issue with pagefile.sys
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
"Unexpected Error"
Resume AbortFunction
End If
End Function
Sub Find_Files()
Dim SearchPath As String, FindStr As String, SearchPath1 As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Dim Filenames As String, Filenames1 As String
Dim r As Range
'Screen.MousePointer = vbHourglass
'List2.Clear
For Each cell In Range("SS")
SearchPath = Sheet3.Range("B2").Value2
SearchPath1 = Sheet3.Range("B3").Value2
FindStr = Cells(cell.Row, "H").Value
Filenames = FindFiles(SearchPath, FindStr)
Filenames1 = FindFiles(SearchPath1, FindStr)
'Sheet1.Range("B1").Value2 = NumFiles & " Files found in " & NumDirs + 1 & _
" Directories"
Cells(cell.Row, "F").Value = Filenames
Cells(cell.Row, "G").Value = Filenames1
'Format(FileSize, "#,###,###,##0") & " Bytes"
'Screen.MousePointer = vbDefault
Next cell
End Sub
Any thoughts will be highly appreciated.
I realize this question is very old, but it is unanswered. Here is a quick method for finding multiple files and their paths. VBA's DIR function isn't really very handy, but CMD's DIR function is well optimized and has a plethora of command line switches to make it return only files (or even just folders) that match your criteria. The trick is to call DIRfrom a WScript shell so that the output can be parsed by VBA.
For example, this snippet of code will find every file on your system that starts with config.
Dim oShell As Object 'New WshShell if you want early binding
Dim cmd As Object 'WshExec if you want early binding
Dim x As Integer
Const WshRunning = 0
Set oShell = CreateObject("Wscript.Shell")
Set cmd = oShell.Exec("cmd /c ""Dir c:\config* /a:-d /b /d /s""")
Do While cmd.Status = WshRunning
DoEvents
Loop
Debug.Print cmd.StdOut.ReadAll
Set oShell = Nothing
Set cmd = Nothing