I'll preface this by saying I don't have much experience in Excel and VBA code, but I've gone through countless sources looking for this.
I'm attempting to store all files in the current working directory in an array and then looping through that array to find the file with the highest number at the end for each base name.
Example: file1.xlsx, file2.xlsx, anotherfile1.xlsx, anotherfile2.xlsx
would only return file2.xlsx and anotherfile2.xlsx.
This is what I currently have as a starting point:
Dim directory As String, fileName As String, sheet As Worksheet
Dim fileArray() As String
Dim count As Integer
Set count = 0
Application.ScreenUpdating = False
directory = ActiveWorkbook.Path
fileName = Dir(directory & "*.xlsm")
Do Until fileName = ""
count = count + 1
ReDim Preserve fileArray(1 To count)
fileArray(count) = fileName
fileName = Dir
Loop
'Find unique entries
For Each element In fileArray
'do stuff here...
Next element
The file names are formatted oddly so I'm not sure how to approach this. The file names are like: GENERICNAME-[field I need to compare]-[number].xlsx
strPath in the below is the most recent file with the name you're looking for.
Dim fsoFile As New FileSystemObject
Dim fldFile As Folder: Set fldFile = fsoFile.GetFolder(ActiveWorkbook.Path)
Dim objFile As File
Dim dtFile As Date: dtFile = DateSerial(1900, 1, 1)
Dim strPath As String
For Each objFile In fldFile.Files
If Not objFile.Name Like "*~$*" Then
If objFile.Name Like "*[file I need to compare]*" _
And objFile.DateLastModified > dtFile Then
dtFile = objFile.DateLastModified
strPath = objFile.Path
End If
End If
Next objFile
Set fsoFile = Nothing
Set fldFile = Nothing
Related
Here is my problem, on my excel sheet I put paths of every folder that I want to check
V:\Folder1\
V:\Folder2\
Inside those folder I want vba to give me the name of the last modified file based on a specific name.
I will give an example:
In my folder1 I have those files :
Lo_2021_1
Lo_Full_2021_1
Lo_2021_2
Lo_Full_2021_2
...
Lo_2021_50
Lo_Full_2021_50
In my folder2 I have those files :
Li_2021_1
Li_Full_2021_1
Li_2021_2
Li_Full_2021_2
...
Li_2021_50
Li_Full_2021_50
I want vba to give me the name of the last modified file that starts with Lo_2021 in my folder1 and Li_2021 in my folder2 (so I don't want Lo_Full and Li_Full)
I already created a code that gave me the name of the last modified files but they are Lo_Full_2021_50 and Li_Full_2021_50 whereas I want Lo_2021_50 and Li_2021_50
Here is my code :
Option Explicit
Sub name_last_file()
Dim FileSys As FileSystemObject
Dim objFile As File
Dim myFolder
Dim strFilename As String
Dim dteFile As Date
Dim list_path As Range
Dim path_ As Range
Dim myDir As String
Set list_path = Range("B2", Range("B2").End(xlDown))
For Each path_ In list_path
myDir = path_.Value
'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
Next objFile
MsgBox strFilename
Next path_
End Sub
This will give me Lo_Full_2021_50 and Li_Full_2021_50 whereas I want Lo_2021_50 and Li_2021_50.
Is there a way to say that I want the last modified file that start with Lo_2021 or Li_2020 so that I will get Lo_2021_50 and Li_2021_50 as a result ?
I'm really thankful for your help
Please, test the next updated code:
Sub Give_name_files()
Dim FileSys As FileSystemObject, objFile As File, myFolder As oobject
Dim strFilename As String, dteFile As Date, list_path As Range, path_ As Range
Dim strRoot As String
strRoot = "Lo_2021" 'the beginning of the tested files name
'First I Select paths that are on my excel cells
Set list_path = Range("B2", Range("B2").End(xlDown))
For Each path_ In list_path
myDir = path_.Value
'Set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If left(objFile.Name, Len(strRoot)) = strRoot Then
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
End If
Next objFile
MsgBox strFilename
Next path_
End Sub
I am trying to edit code that someone else wrote. I have done NO VBA and very little coding in general.
The original code is written for a 5 digit number and we now have files that are six digits. I have tried to copy the code but change it to 6 digit numbers below the current code above Next objFile at the end. This has not worked.
The main issue here is I didn't write the original code and I don't understand the logic. I have tried just changing all of the 5's to 6's and the 99999 to 999999. I have tried copying from Folder = "" down, changing them to 6 digits and pasting below Next objFile. This didn't work either.
Sub CopyPics()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim varDirectory As Variant
Dim objSubFolder As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Application.ActiveWorkbook.Path)
Dim Dest As String
Dest = "R:\Field Assurance\FA PHOTOS AND INFORMATION\"
'Loop through each file in this folder
For Each objFile In objFolder.Files
Folder = "" 'Empty old folder name
MainFolder = "" 'Empty old folder name
For i = 1 To Len(objFile.Name)
Test = Mid(objFile.Name, i, 5)
If Test >= 10000 And Test <= 99999 Then 'For files: Find any five numbers in a row and assume it to be the file number.
Folder = "NC-" & Mid(objFile.Name, i, 5) 'If found, create new folder.
i = Len(objFile.Name) 'In other words, take the first 5 numbers, then get out.
End If
Next
For Each objSubFolder In objFolder.subfolders 'Find the main folder.
If Right(Folder, 5) >= Mid(objSubFolder.Name, 4, 5) And Right(Folder, 5) <= Mid(objSubFolder.Name, 18, 5) Then 'If my file number is within the main folder bounds...
MainFolder = objSubFolder.Name & "\" 'Use that folder.
End If
Next objSubFolder
If Len(Folder) = 8 And Len(MainFolder) = 23 Then 'If real folders are identified...
On Error Resume Next
If Dir(Dest & MainFolder & Folder) = "" Then 'Check to see if the directory/folder does not exist...
objFSO.CreateFolder (Dest & MainFolder & Folder) 'If not, make one.
End If
'Rename that file's directory to be the new one - aka cut and paste file into new folder.
Name Application.ActiveWorkbook.Path & "\" & objFile.Name As Dest & MainFolder & Folder & "\" & objFile.Name
End If
Next objFile
ActiveWorkbook.Close
End Sub
This is a bit more complex than your original code but I think it's more robust...
Lightly tested.
Option Explicit
Sub CopyPics()
'use constants for fixed values
Const DEST As String = "R:\Field Assurance\FA PHOTOS AND INFORMATION\"
Dim objFSO As Object, srcFolder As Object, objFile As Object
Dim objSubFolder As Object, destFolder As Object, fNum, folderName, picFolderName
Dim FileWasMoved As Boolean, sMsg
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set srcFolder = objFSO.GetFolder(Application.ActiveWorkbook.Path) 'ThisWorkbook.Path ?
Set destFolder = objFSO.GetFolder(DEST) 'parent destination folder
'Loop through each file in this folder
For Each objFile In srcFolder.Files
FileWasMoved = False 'reset "moved" flag
fNum = ExtractNumber(objFile.Name) 'get the file number
If Len(fNum) > 0 Then 'any number found?
folderName = "NC-" & fNum
For Each objSubFolder In destFolder.subfolders 'Find the subfolder.
If IsTheCorrectFolder(objSubFolder.Name, fNum) Then
picFolderName = objSubFolder.Path & "\" & folderName
If Not objFSO.folderexists(picFolderName) Then
objFSO.CreateFolder picFolderName
End If
'move the file
Name objFile.Path As picFolderName & "\" & objFile.Name
FileWasMoved = True 'flag file as moved
Exit For
End If
Next objSubFolder
End If 'filename contains a number
'if file was not moved then add it to the list....
If Not FileWasMoved Then sMsg = sMsg & vbLf & objFile.Name
Next objFile
'warn user if some files were not moved
If Len(sMsg) > 0 Then
MsgBox "Some files were not moved:" & vbLf & sMsg, vbExclamation
End If
End Sub
'Return true/false depending on whether this is the correct
' folder to hold the specified filenumber
Function IsTheCorrectFolder(folderName, fileNumber) As Boolean
Dim arr, num1, num2, rv As Boolean
rv = False 'default return value
arr = Split(folderName, "thru") 'split folder name on "thru"
If UBound(arr) = 1 Then 'should have two parts
'get the numbers from each part and compare against the file number
num1 = ExtractNumber(arr(0))
num2 = ExtractNumber(arr(1))
If Len(num1) > 0 And Len(num2) > 0 Then
fileNumber = CLng(fileNumber) 'convenrt to Long for comparison
rv = (fileNumber >= CLng(num1) And fileNumber <= CLng(num2))
End If
End If
IsTheCorrectFolder = rv
End Function
'Extract the first 5- or 6-digit number from a string
' Match is "greedy" so if there are six digits it will match 6 and
' not just the first 5...
Function ExtractNumber(txt)
Dim re As Object, allMatches, rv
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "(\d{5,6})"
re.ignorecase = True
re.Global = True
Set allMatches = re.Execute(txt)
If allMatches.Count > 0 Then rv = allMatches(0) 'if there's a match then return the first one
ExtractNumber = rv
End Function
You need to change the lower limit in IF condition also. Like
If Test >= 10000 And Test <= 99999 Then
becomes
If Test >= 100000 And Test <= 999999 Then
Currently the loop could be exiting when it finds the first five digit number.
Hi I am trying to open the latest file (date modified) in a folder. The code uses a loop to go through the files and find the latest modified which it does however when it comes to open the file using 'Workbooks.Open strFilename' it says the file (which it has already identified as the 'youngest' file could not be found. This doesn't make sense to me as the error message says the file 'test young' - the file name could not be found, but it clearly found it during the loop.
Sub copynewdata()
Dim FileSys As FileSystemObject
Dim objFile As File
Dim myFolder
Dim strFilename As String
Dim dteFile As Date
Dim Ref As Object, CheckRefEnabled%
CheckRefEnabled = 0
With ThisWorkbook
For Each Ref In .VBProject.References
If Ref.Name = "Scripting" Then
CheckRefEnabled = 1
Exit For
End If
Next Ref
If CheckRefEnabled = 0 Then
.VBProject.References.AddFromGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
End If
End With
'set path for files - change for your folder
Const myDir As String = "\\C:\Test"
'set up filesys objects
Set FileSys = New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
'loop through each file and get date last modified. If largest date then store Filename
dteFile = DateSerial(1900, 1, 1)
For Each objFile In myFolder.Files
If objFile.DateLastModified > dteFile Then
dteFile = objFile.DateLastModified
strFilename = objFile.Name
End If
Next objFile
Workbooks.Open strFilename
'Set Source_Workbook = Workbooks(strFilename).Open(Target_Path)
Set FileSys = Nothing
Set myFolder = Nothing
End Sub
Can anyone help with this?
In strFilename, you have the name of the file - but without the path. Change the open-command to
Workbooks.Open myDir & "\" & strFilename
Please help with the code for copying files one by one to the destination folder. I tried with "for Each loop but it is copying all the files at once to the destination folder. I am new to to vba and would be helpful if someone could crack the code for me. thanks in advance. here's the code i have managed to come up with.
I am getting run time error 53, File not found,e highlighting the below syntax.
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Sub Example1()
'Extracting file names Dim objFSO As Object Dim objFolder As Object Dim newobjFile As Object
Dim lastID As Long Dim myRRange As Range Dim Maxvalue As Integer
Dim sFolder As String Dim dFolder As String
Sub Example1()
'Extracting file names
Dim FSO
Dim objFolder As Object
Dim newobjFile As Object
Dim FromDir As String
Dim ToDir As String
Dim lastID As Long
Dim myRRange As Range
Dim Maxvalue As Integer
Dim Fname As String
FromDir = "C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\"
ToDir = "C:\Users\wazeer.ahamed\Documents\TcktIDfolder\"
Fname = Dir(FromDir)
If Len(FromDir) = 0 Then
MsgBox "No files"
Exit Sub
End If
Set myRange = Worksheets("Sheet1").Range("C:C")
Maxvalue = Application.WorksheetFunction.Max(myRange)
lastID = Maxvalue
'finding the next availabe row
erow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Extracting file names
'Create an instance of the FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = FSO.GetFolder("C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro")
'loops through each file in the directory and prints their names and path
For Each newobjFile In objFolder.Files
'print file name
Cells(erow, 1) = Fname
'print file path
Cells(erow, 2) = newobjFile.Path
'PrintUniqueID
Cells(erow, 3) = lastID + 1
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Cells(erow, 5) = "file succesfully copied"
Next newobjFile
Set FSO = Nothing
Set newobjFile = Nothing
Set objFolder = Nothing
End Sub
I think that the code can be more simple and dynamic if you play with your own excel file.
Use "A1" range to put the source folder.
Use "B:B" range to put the
name of the files.
Use "C:C" range to concatenate the previous
columns.
Use "D1" range to put the destination folder.
Sub copyFiles()
'Macro for copy files
'Set variable
Dim source As String
Dim destination As String
Dim x As Integer
Dim destinationNumber As Integer
destinationNumber = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("C:C"))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Create the folder if not exist
If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1"), 16) = "" Then
MkDir ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1")
End If
'Run the loop to copy all the files
For x = 1 To destinationNumber
source = ThisWorkbook.Sheets("Sheet1").Range("C" & x)
destination = ThisWorkbook.Sheets("Sheet1").Range("D1")
FileCopy source, destination
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
With this you can change the folders' paths and file names whenever you want. I've used FileCopy to preserve your files in the source but if you need to delete it's better use other method.
This question already has answers here:
Cycle through sub-folders and files in a user-specified root directory [duplicate]
(3 answers)
Closed 1 year ago.
I need to get the names of all the Excel files in a folder and then make changes to each file. I've gotten the "make changes" part sorted out. Is there a way to get a list of the .xlsx files in one folder, say D:\Personal and store it in a String Array.
I then need to iterate through the list of files and run a macro on each of the files which I figured I can do using:
Filepath = "D:\Personal\"
For Each i in FileArray
Workbooks.Open(Filepath+i)
Next
I had a look at this, however, I wasn't able to open the files cause it stored the names in Variant format.
In short, how can I use VBA to get a list of Excel filenames in a specific folder?
Ok well this might work for you, a function that takes a path and returns an array of file names in the folder. You could use an if statement to get just the excel files when looping through the array.
Function listfiles(ByVal sPath As String)
Dim vaArray As Variant
Dim i As Integer
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
Set oFiles = oFolder.Files
If oFiles.Count = 0 Then Exit Function
ReDim vaArray(1 To oFiles.Count)
i = 1
For Each oFile In oFiles
vaArray(i) = oFile.Name
i = i + 1
Next
listfiles = vaArray
End Function
It would be nice if we could just access the files in the files object by index number but that seems to be broken in VBA for whatever reason (bug?).
You can use the built-in Dir function or the FileSystemObject.
Dir Function: VBA: Dir Function
FileSystemObject: VBA: FileSystemObject - Files Collection
They each have their own strengths and weaknesses.
Dir Function
The Dir Function is a built-in, lightweight method to get a list of files. The benefits for using it are:
Easy to Use
Good performance (it's fast)
Wildcard support
The trick is to understand the difference between calling it with or without a parameter. Here is a very simple example to demonstrate:
Public Sub ListFilesDir(ByVal sPath As String, Optional ByVal sFilter As String)
Dim sFile As String
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If sFilter = "" Then
sFilter = "*.*"
End If
'call with path "initializes" the dir function and returns the first file name
sFile = Dir(sPath & sFilter)
'call it again until there are no more files
Do Until sFile = ""
Debug.Print sFile
'subsequent calls without param return next file name
sFile = Dir
Loop
End Sub
If you alter any of the files inside the loop, you will get unpredictable results. It is better to read all the names into an array of strings before doing any operations on the files. Here is an example which builds on the previous one. This is a Function that returns a String Array:
Public Function GetFilesDir(ByVal sPath As String, _
Optional ByVal sFilter As String) As String()
'dynamic array for names
Dim aFileNames() As String
ReDim aFileNames(0)
Dim sFile As String
Dim nCounter As Long
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If sFilter = "" Then
sFilter = "*.*"
End If
'call with path "initializes" the dir function and returns the first file
sFile = Dir(sPath & sFilter)
'call it until there is no filename returned
Do While sFile <> ""
'store the file name in the array
aFileNames(nCounter) = sFile
'subsequent calls without param return next file
sFile = Dir
'make sure your array is large enough for another
nCounter = nCounter + 1
If nCounter > UBound(aFileNames) Then
'preserve the values and grow by reasonable amount for performance
ReDim Preserve aFileNames(UBound(aFileNames) + 255)
End If
Loop
'truncate the array to correct size
If nCounter < UBound(aFileNames) Then
ReDim Preserve aFileNames(0 To nCounter - 1)
End If
'return the array of file names
GetFilesDir = aFileNames()
End Function
File System Object
The File System Object is a library for IO operations which supports an object-model for manipulating files. Pros for this approach:
Intellisense
Robust object-model
You can add a reference to to "Windows Script Host Object Model" (or "Windows Scripting Runtime") and declare your objects like so:
Public Sub ListFilesFSO(ByVal sPath As String)
Dim oFSO As FileSystemObject
Dim oFolder As Folder
Dim oFile As File
Set oFSO = New FileSystemObject
Set oFolder = oFSO.GetFolder(sPath)
For Each oFile In oFolder.Files
Debug.Print oFile.Name
Next 'oFile
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
If you don't want intellisense you can do like so without setting a reference:
Public Sub ListFilesFSO(ByVal sPath As String)
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sPath)
For Each oFile In oFolder.Files
Debug.Print oFile.Name
Next 'oFile
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Dim iIndex as Integer
Dim ws As Excel.Worksheet
Dim wb As Workbook
Dim strPath As String
Dim strFile As String
strPath = "D:\Personal\"
strFile = Dir(strPath & "*.xlsx")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strPath & strFile)
For iIndex = 1 To wb.Worksheets.count
Set ws = wb.Worksheets(iIndex)
'Do something here.
Next iIndex
strFile = Dir 'This moves the value of strFile to the next file.
Loop
If all you want is the file name without file extension
Dim fileNamesCol As New Collection
Dim MyFile As Variant 'Strings and primitive data types aren't allowed with collection
filePath = "c:\file directory" + "\"
MyFile = Dir$(filePath & "*.xlsx")
Do While MyFile <> ""
fileNamesCol.Add (Replace(MyFile, ".xlsx", ""))
MyFile = Dir$
Loop
To output to excel worksheet
Dim myWs As Worksheet: Set myWs = Sheets("SheetNameToDisplayTo")
Dim ic As Integer: ic = 1
For Each MyFile In fileNamesCol
myWs.Range("A" & ic).Value = fileNamesCol(ic)
ic = ic + 1
Next MyFile
Primarily based on the technique detailed here: https://wordmvp.com/FAQs/MacrosVBA/ReadFilesIntoArray.htm
Regarding the upvoted answer, I liked it except that if the resulting "listfiles" array is used in an array formula {CSE}, the list values come out all in a horizontal row. To make them come out in a vertical column, I simply made the array two dimensional as follows:
ReDim vaArray(1 To oFiles.Count, 0)
i = 1
For Each oFile In oFiles
vaArray(i, 0) = oFile.Name
i = i + 1
Next
Sub test()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder1 = FSO.GetFolder(FromPath).Files
FolderPath_1 = "D:\Arun\Macro Files\UK Marco\External Sales Tool for Au\Example Files\"
Workbooks.Add
Set Movenamelist = ActiveWorkbook
For Each fil In folder1
Movenamelist.Activate
Range("A100000").End(xlUp).Offset(1, 0).Value = fil
ActiveCell.Offset(1, 0).Select
Next
End Sub