Excel Macro to convert xlsx to xls - excel

i have bunch of files in folder all of them are in xlsx format, I need to convert them to xls format. This is going to be done on daily bases.
I need a macro which will loop around the folder and convert the file to xls from xlsx with out changing file name.?
Here is the macro I am using to loop
Sub ProcessFiles()
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "C:\Users\myfolder1\Desktop\myfolder\Macro\"
Filename = Dir(Pathname & "*.xls")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
DoWork wb
wb.Close SaveChanges:=True
Filename = Dir()
Loop
End Sub

What you are missing is that instead of calling wb.Close SaveChanges=True to save the file in another format, you need to call wb.SaveAs with the new file format and name.
You said you want to convert them without changing the file name, but I suspect you really meant you want to save them with the same base file name, but with the .xls extension. So if the workbook is named book1.xlsx, you want to save it as book1.xls. To calculate the new name you can do a simple Replace() on the old name replacing the .xlsx extension with .xls.
You can also disable the compatibility checker by setting wb.CheckCompatibility, and suppress alerts and messages by setting Application.DisplayAlerts.
Sub ProcessFiles()
Dim Filename, Pathname, saveFileName As String
Dim wb As Workbook
Dim initialDisplayAlerts As Boolean
Pathname = "<insert_path_here>" ' Needs to have a trailing \
Filename = Dir(Pathname & "*.xlsx")
initialDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=Pathname & Filename, _
UpdateLinks:=False)
wb.CheckCompatibility = False
saveFileName = Replace(Filename, ".xlsx", ".xls")
wb.SaveAs Filename:=Pathname & saveFileName, _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close SaveChanges:=False
Filename = Dir()
Loop
Application.DisplayAlerts = initialDisplayAlerts
End Sub

Sub SaveAllAsXLSX()
Dim strFilename As String
Dim strDocName As String
Dim strPath As String
Dim wbk As Workbook
Dim fDialog As FileDialog
Dim intPos As Integer
Dim strPassword As String
Dim strWritePassword As String
Dim varA As String
Dim varB As String
Dim colFiles As New Collection
Dim vFile As Variant
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = True
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
If Left(strPath, 1) = Chr(34) Then
strPath = Mid(strPath, 2, Len(strPath) - 2)
End If
Set obj = CreateObject("Scripting.FileSystemObject")
RecursiveDir colFiles, strPath, "*.xls", True
For Each vFile In colFiles
Debug.Print vFile
strFilename = vFile
varA = Right(strFilename, 3)
If (varA = "xls" Or varA = "XLS") Then
Set wbk = Workbooks.Open(Filename:=strFilename)
If wbk.HasVBProject Then
wbk.SaveAs Filename:=strFilename & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
wbk.SaveAs Filename:=strFilename & "x", FileFormat:=xlOpenXMLWorkbook
End If
wbk.Close SaveChanges:=False
obj.DeleteFile (strFilename)
End If
Next vFile
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function

Related

Converting multiple xlsl files to xls (97-2003 Worksheet) extension without changing the names

I am trying to loop through all the 'xlsx' files in a folder and convert them to 'xls' ( Excel 97-2003 Worksheet) format. I use the following codes but then the output files are still saved as 'xlsx' instead of 'xls'. I am a beginner and looking to learn more from others. Thanks for your help!
Sub Convert()
Dim strPath As String
Dim strFile As String
Dim strfilenew As String
Dim xWbk As Workbook
Dim xSFD, xRFD As FileDialog
Dim xSPath As String
Dim xRPath As String
Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)
With xSFD
.Title = "Please select the folder contains the xls files:"
.InitialFileName = "C:\"
End With
If xSFD.Show <> -1 Then Exit Sub
xSPath = xSFD.SelectedItems.Item(1)
Set xRFD = Application.FileDialog(msoFileDialogFolderPicker)
With xRFD
.Title = "Please select a folder for outputting the new files:"
.InitialFileName = "C:\"
End With
If xRFD.Show <> -1 Then Exit Sub
xRPath = xRFD.SelectedItems.Item(1) & "\"
strPath = xSPath & "\"
strFile = Dir(strPath & "*.xlsx")
strfilenew = Dir(strPath & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While strFile <> ""
If Right(strFile, 4) = "xlsx" Then
Set xWbk = Workbooks.Open(Filename:=strPath & strfilenew)
xWbk.SaveAs Filename:=xRPath & strfilenew, _
FileFormat:=xlExcel18
xWbk.Close SaveChanges:=True
End If
strFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There was a bit of a mix-up in your file naming, basically as evidenced by the several double-declarations that I removed. The really big mistake was here, Set xWbk = Workbooks.Open(Filename:=strPath & strfilenew) where you tried to open the old workbook by the new name. I think the confusion started here "Please select the folder contains the xls files:". Of course, this is the folder with the XLSX files. The recommended antidote is to use "meaningful" variable names but you chose to speak in riddles (like xSFD) which makes coding more difficult.
However, the code below is largely yours, and it does work.
Sub Convert()
' 230
Dim Spath As String ' path to read from (XLSX files)
Dim Rpath As String ' path to write to (XLS files)
Dim strFile As String ' loop variable: current file name
Dim Wbk As Workbook ' loop object: current workbook(strFile)
Dim Sp() As String ' split array of strFile
Dim strFileNew As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the folder contains the XLSX files:"
.InitialFileName = "C:\"
If .Show <> -1 Then Exit Sub
Spath = .SelectedItems.Item(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder for outputting the new files:"
.InitialFileName = "C:\"
If .Show <> -1 Then Exit Sub
Rpath = .SelectedItems.Item(1) & "\"
End With
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
strFile = Dir(Spath & "*.xlsx")
Do While strFile <> ""
If Right(strFile, 4) = "xlsx" Then
Sp = Split(strFile, ".")
Sp(UBound(Sp)) = "xls"
strFileNew = Join(Sp, ".")
Set Wbk = Workbooks.Open(Filename:=Spath & strFile)
Wbk.SaveAs Filename:=Rpath & strFileNew, FileFormat:=xlExcel8
Wbk.Close SaveChanges:=True
End If
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Observe that the new file name is created by splitting the old name on periods, changing the last element, and reassembling the modified array.

How do I search through folders of a subfolder? [duplicate]

I have macro, if I put in cell E1 name of the file, macro search trough C:\Users\Marek\Desktop\Makro\ directory, find it and put the needed values in specific cells of my original file with macro.
Is it possible to make this work without specific folder location? I need something that can search trough C:\Users\Marek\Desktop\Makro\ with many subfolders in it.
My code:
Sub Zila1()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim YrMth As String
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Sheets("Sheet1").Range("E1").Text
If FName = False Then
'do nothing
Else
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Just for fun, here's a sample with a recursive function which (I hope) should be a bit simpler to understand and to use with your code:
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
Call TestSub(mySubFolder.Path)
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
Sub TestSub(ByVal s As String)
Debug.Print s
End Sub
Edit: Here's how you can implement this code in your workbook to achieve your objective.
Sub TestSub(ByVal s As String)
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name 'Or do whatever you want with the file
End If
Next
End Sub
Here, I just debug the name of the found file, the rest is up to you. ;)
Of course, some would say it's a bit clumsy to call twice the FileSystemObject so you could simply write your code like this (depends on wether you want to compartmentalize or not):
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file
Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
This sub will populate a Collection with all files matching the filename or pattern you pass in.
Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)
Dim f As String, sf As String, subF As New Collection, s
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop
If DoSubfolders then
sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop
For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s
End If
End Sub
Usage:
Dim colFiles As New Collection
GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles
If colFiles.Count > 0 Then
'work with found files
End If
If this helps, you can also use FileSystemObject to retrieve all subfolders of a folder.
You need to check the reference "Microsot Scripting Runtime" to get Intellisense and use the "new" keyword.
Sub GetSubFolders()
Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder
Set f = fso.GetFolder("D:\Proj\")
For Each sf In f.SubFolders
'Code inside
Next
End Sub
I actually just found this today for something I'm working on. This will return file paths for all files in a folder and its subfolders.
Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True
Dim vFile As Variant
For Each vFile In colFiles
'file operation here or store file name/path in a string array for use later in the script
filepath(n) = vFile
filename = fso.GetFileName(vFile) 'If you want the filename without full path
n=n+1
Next vFile
'These two functions are required
Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
This is adapted from a post by Ammara Digital Image Solutions.(http://www.ammara.com/access_image_faq/recursive_folder_search.html).

Loop Through Folders and SubFolders - Multiple Folder Path [duplicate]

I have macro, if I put in cell E1 name of the file, macro search trough C:\Users\Marek\Desktop\Makro\ directory, find it and put the needed values in specific cells of my original file with macro.
Is it possible to make this work without specific folder location? I need something that can search trough C:\Users\Marek\Desktop\Makro\ with many subfolders in it.
My code:
Sub Zila1()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim YrMth As String
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Sheets("Sheet1").Range("E1").Text
If FName = False Then
'do nothing
Else
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Just for fun, here's a sample with a recursive function which (I hope) should be a bit simpler to understand and to use with your code:
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
Call TestSub(mySubFolder.Path)
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
Sub TestSub(ByVal s As String)
Debug.Print s
End Sub
Edit: Here's how you can implement this code in your workbook to achieve your objective.
Sub TestSub(ByVal s As String)
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name 'Or do whatever you want with the file
End If
Next
End Sub
Here, I just debug the name of the found file, the rest is up to you. ;)
Of course, some would say it's a bit clumsy to call twice the FileSystemObject so you could simply write your code like this (depends on wether you want to compartmentalize or not):
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file
Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
This sub will populate a Collection with all files matching the filename or pattern you pass in.
Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)
Dim f As String, sf As String, subF As New Collection, s
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop
If DoSubfolders then
sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop
For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s
End If
End Sub
Usage:
Dim colFiles As New Collection
GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles
If colFiles.Count > 0 Then
'work with found files
End If
If this helps, you can also use FileSystemObject to retrieve all subfolders of a folder.
You need to check the reference "Microsot Scripting Runtime" to get Intellisense and use the "new" keyword.
Sub GetSubFolders()
Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder
Set f = fso.GetFolder("D:\Proj\")
For Each sf In f.SubFolders
'Code inside
Next
End Sub
I actually just found this today for something I'm working on. This will return file paths for all files in a folder and its subfolders.
Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True
Dim vFile As Variant
For Each vFile In colFiles
'file operation here or store file name/path in a string array for use later in the script
filepath(n) = vFile
filename = fso.GetFileName(vFile) 'If you want the filename without full path
n=n+1
Next vFile
'These two functions are required
Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
This is adapted from a post by Ammara Digital Image Solutions.(http://www.ammara.com/access_image_faq/recursive_folder_search.html).

How to loop a Subfolder in a Function GetFolderName [duplicate]

I have macro, if I put in cell E1 name of the file, macro search trough C:\Users\Marek\Desktop\Makro\ directory, find it and put the needed values in specific cells of my original file with macro.
Is it possible to make this work without specific folder location? I need something that can search trough C:\Users\Marek\Desktop\Makro\ with many subfolders in it.
My code:
Sub Zila1()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant
Dim YrMth As String
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Sheets("Sheet1").Range("E1").Text
If FName = False Then
'do nothing
Else
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False
GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _
"AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Just for fun, here's a sample with a recursive function which (I hope) should be a bit simpler to understand and to use with your code:
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
Call TestSub(mySubFolder.Path)
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
Sub TestSub(ByVal s As String)
Debug.Print s
End Sub
Edit: Here's how you can implement this code in your workbook to achieve your objective.
Sub TestSub(ByVal s As String)
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(s)
For Each myFile In myFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name 'Or do whatever you want with the file
End If
Next
End Sub
Here, I just debug the name of the found file, the rest is up to you. ;)
Of course, some would say it's a bit clumsy to call twice the FileSystemObject so you could simply write your code like this (depends on wether you want to compartmentalize or not):
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
For Each myFile In mySubFolder.Files
If myFile.Name = Range("E1").Value Then
Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file
Exit For
End If
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse("D:\Projets\")
End Sub
This sub will populate a Collection with all files matching the filename or pattern you pass in.
Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)
Dim f As String, sf As String, subF As New Collection, s
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop
If DoSubfolders then
sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop
For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s
End If
End Sub
Usage:
Dim colFiles As New Collection
GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles
If colFiles.Count > 0 Then
'work with found files
End If
If this helps, you can also use FileSystemObject to retrieve all subfolders of a folder.
You need to check the reference "Microsot Scripting Runtime" to get Intellisense and use the "new" keyword.
Sub GetSubFolders()
Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder
Set f = fso.GetFolder("D:\Proj\")
For Each sf In f.SubFolders
'Code inside
Next
End Sub
I actually just found this today for something I'm working on. This will return file paths for all files in a folder and its subfolders.
Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True
Dim vFile As Variant
For Each vFile In colFiles
'file operation here or store file name/path in a string array for use later in the script
filepath(n) = vFile
filename = fso.GetFileName(vFile) 'If you want the filename without full path
n=n+1
Next vFile
'These two functions are required
Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
This is adapted from a post by Ammara Digital Image Solutions.(http://www.ammara.com/access_image_faq/recursive_folder_search.html).

open last modified excel spreadsheet using vba

I have the following code that i have used to open the last modified CSV file, and have literally just changed the path name and extension, but it now doesnt work, would appreciate any pointers on where i am going wrong:
Code i am using:
Sub ReceiptTest()
On Error Resume Next
With Application.FileSearch
.LookIn = "\\K123456\shared\IT Public\ReceiptsETE\Archive\": .Filename = "*.XLS*"
.Execute msoSortByLastModified, msoSortOrderDescending
For FF = 1 To .FoundFiles.Count
If FileDateTime(.FoundFiles(FF)) > LastModDate Then
LastModDate = FileDateTime(.FoundFiles(FF))
lmf = .FoundFiles(FF)
End If
Next
End With
Workbooks.Open (lmf)
End Sub
Thanks
If you're trying to open a CSV, then your filename should be .csv, not xls. Here's how I do it. You need to set a reference to Microsoft Scripting Runtime. It will work even when you upgrade from 2003
Sub OpenCSV()
Dim sFldr As String
Dim fso As Scripting.FileSystemObject
Dim fsoFile As Scripting.File
Dim fsoFldr As Scripting.Folder
Dim dtNew As Date, sNew As String
Const sCSVTYPE As String = "Microsoft Office Excel Comma Separated Values File"
Set fso = New Scripting.FileSystemObject
sFldr = "C:\Documents and Settings\dick\My Documents\QBExport\"
Set fsoFldr = fso.GetFolder(sFldr)
For Each fsoFile In fsoFldr.Files
If fsoFile.DateLastModified > dtNew And fsoFile.Type = sCSVTYPE Then
sNew = fsoFile.Path
dtNew = fsoFile.DateLastModified
End If
Next fsoFile
Workbooks.Open sNew
End Sub
Ok, I got this to work using Conman's code above with a few modification (I made changes to his code and they will be reflected if they get approved). Here is his code with those changes:
Sub GetLatestFile()
Dim strFolder As String
Dim strFile As String
Dim latestFile As String
Dim dtLast As Date
' assign variables
strFolder = "C:\your\file\path\goes\here\" 'the path of the file drop folder (you need the final "\" on the directory
strFile = Dir(strFolder & "\*.xls*", vbNormal) ' Excel Files
' strFile = Dir(strFolder & "\*.csv", vbNormal) ' CSV Files
' strFile = Dir(strFolder & "\*.*", vbNormal) ' Any File
' loop through files to find latest modified date
Do While strFile <> ""
If FileDateTime(strFolder & strFile) > dtLast Then
dtLast = FileDateTime(strFolder & strFile)
latestFile = strFolder & strFile
End If
strFile = Dir
Loop
MsgBox latestFile
End Sub
You can also set strFolder by using a file dialogue and passing it into the above sub. Here is an example:
Sub ChooseFolder()
Dim fd As Office.FileDialog
Dim strFolder As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
If .Show Then
strFolder = .SelectedItems(1)
End If
End With
GetLatestFile strFolder
End Sub
Sub GetLatestFile(strFolder As String)
Dim strFile As String
Dim latestFile As String
Dim dtLast As Date
' assign variables
strFolder = strFolder & "\"
strFile = Dir(strFolder & "\*.xls*", vbNormal) ' Excel Files
' strFile = Dir(strFolder & "\*.csv", vbNormal) ' CSV Files
' strFile = Dir(strFolder & "\*.*", vbNormal) ' Any File
' loop through files to find latest modified date
Do While strFile <> ""
If FileDateTime(strFolder & strFile) > dtLast Then
dtLast = FileDateTime(strFolder & strFile)
latestFile = strFolder & strFile
End If
strFile = Dir
Loop
MsgBox latestFile
End Sub
I just tested both chucks of code and they work for me. Let me know if you can't get them to work.
I cannot test your code as I am using Execl 2010 and Application.FileSearch isn't supported.
I use this to find the latest modified file...
Sub GetLatestFile()
Dim strFolder As String
Dim strFile As String
Dim latestFile As String
Dim dtLast As Date
' assign variables
strFolder = "C:\" 'The end of this path must have a \ on it
strFile = Dir(strFolder & "\*.*", vbNormal) ' Any File
' strFile = Dir(strFolder & "\*.xls*", vbNormal) ' Excel Files
' strFile = Dir(strFolder & "\*.csv", vbNormal) ' CSV Files
' loop through files to find latest modified date
Do While strFile <> ""
If FileDateTime(strFolder & strFile) > dtLast Then
dtLast = FileDateTime(strFolder & strFile)
latestFile = strFolder & strFile
End If
strFile = Dir
Loop
MsgBox latestFile
End Sub

Resources