I have a problem that I can't find the right code to do it.
So I have a Main Folder (C:\Products) with multiple subfolders that correspond to different the products (C:\Products\Chocolates , C:\Products\Milk and many more).
Each subfolder have many excel files but I just want to import the one that is named sells.xlxs. Each subfolder have a sells.xlxs and I Want to import all sells.xlxs to an access Database.
EDIT: Sorry I didn't Upload the code I was using:
Sub Insert2()
Const cstrSheetName As String = "Weekly"
Dim strDir As String
Dim strFile As String
Dim strTableName As String
Dim MyPath As String
Dim i As Long
i = 0
MyPath = "C:\Products"
strTableName = "Sells"
If Left(MyPath, 1) <> "\" Then
strDir = MyPath & "\"
Else
strDir = MyPath
End If
strFile = Dir(MyPath & "\Sells.XLSX")
While strFile <> ""
i = i + 1
strFile = strDir & strFile
Debug.Print "importing " & strFile
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=acSpreadsheetTypeExcel9, _
TableName:=strTableName, _
FileName:=strFile, _
HasFieldNames:=True, _
Range:=cstrSheetName & "$"
strFile = Dir()
Wend
End Sub
Do you think you can help me?
Many thanks
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = MyPath
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
Dim File
For Each File In Folder.Files
' Operate on each file
Next
Next
End Sub
Code credit to Rich, rearranged code so it doesn't recursively iterate all subfolders, just the subfolders of MyPath
Related
I'm completely new to VBA and had some trouble googling this problem cause variable has multiple meanings.
I am trying to open a file and assign its name to a variable. The file's name is never the same though I always download it to the same folder (one file in that folder only). The only recognizable thing about the file are 3 letters "ABC".
So far I managed to get opening the file to work but not assigning the non-standardized file name to a variable.
Sub openwb()
Dim wb As Workbook Dim directory As String
directory = "D:\Users\AAA\Desktop\Practice"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder(directory)
For Each file In folder.Files
If Mid(file.Name, InStrRev(file.Name, ".") + 1) = "xlsm" Then
Workbooks.Open directory & Application.PathSeparator & file.Name
End If
Next file
End Sub
Public Sub RecordFileName()
Dim sPath As String, sFile As String
Dim wb As Workbook
sPath = "D:\Users\AAA\Desktop\Practice"
sFile = sPath & "*ABC*"
End Sub
Here is a function you can use. It will return the filename you are looking for, and you can specify a file pattern if you want to, or you can omit that argument and it will assume all files.
Function GetFullFileName(sFolder As String, Optional sPattern As String = "*") As String
Dim sFile As String
' ensure sFolder ends with a backslash
If Right$(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
sFile = Dir(sFolder & sPattern)
If sFile = "" Then
MsgBox "NOT FOUND: " & sFolder & sPattern
End
End If
GetFullFileName = sFolder & sFile
End Function
Usage:
MsgBox GetFullFileName("C:\Users\Fred\Documents")
Or
MsgBox GetFullFileName("C:\Users\Fred\Documents\", "*ABC*.xlsm")
Or
sFullFile = GetFullFileName("C:\Users\Fred\Documents\", "*ABC*.xlsm")
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).
I run this code daily that will affect each .xlsx workbook in the directory, but how can I ignore the workbook if the file name is not in the "Okay" array?
This is my current syntax:
Option Explicit
Public Sub OpenExcelInDir()
Dim MyFolder As String
Dim MyFile As String
MyFolder = "C:\ExcelSheets"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
MyFile = Dir
Call UpdateAllSheets
Loop
End Sub
Now I want to alter it so that I can declare a string array and only open the workbooks in the array something like so:
Dim goodWB() As String
goodWB= Split("ABC123,DEF456,GHI789", ",")
Even though I like the IsInArray function I think the algorithm is utterly inefficient. If you have 1000 files in that folder you will create 1000 temp arrays if one of the few given filenames match. Furthermore, I would expect that after opening one of the wanted files the code would not test against this name anymore (which is not the case).
Instead I propose to look at the problem from the other end:
Public Sub OpenExcelInDir()
Dim goodWB, filename
Dim MyFolder As String
Dim MyFile As String
goodWB = Array("ABC123.xls", "DEF456.xlsx", "GHI789.xlsx")
MyFolder = "C:\ExcelSheets"
For Each filename In goodWB
MyFile = MyFolder & "\" & filename
If Len(Dir(MyFile)) > 0 Then
Workbooks.Open filename:=MyFile
Call UpdateAllSheets
End If
Next WB
End Sub
Here, the Dir() function is used to test for the existance of the wanted filename in the specified folder. As an additional advantage there won't be any ambiguities like EEM mentioned in his/her comment.
I think this will do what you are asking for. I added a line to test if the file name matched one in the array.
Tested
Option Explicit
Public Sub OpenExcelInDir()
Dim goodWB() As String
goodWB = Split("ABC123.xlsx,DEF456.xlsx,GHI789.xlsx", ",")
Dim MyFolder As String
Dim MyFile As String
MyFolder = "C:\ExcelSheets"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
If IsInArray(MyFile, goodWB) Then
Workbooks.Open Filename:=MyFolder & "\" & MyFile
MyFile = Dir
Call UpdateAllSheets
End If
MyFile = Dir
Loop
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Public Sub OpenExcelInDir()
Const kExt As String = ".xlsm" `As extension is fixed it could be defined as a constant to avoid repetition
Dim aWbks As Variant, vItm As Variant ‘Suggest to define the array in one step choose the form you prefer
‘aWbks = Array("ABC123", "DEF456", "GHI789")
aWbks = [{"ABC123", "DEF456", "GHI789"}]
Dim MyFolder As String
Dim MyFile As String
MyFolder = "C:\ExcelSheets"
MyFile = Dir(MyFolder & "\*" & kExt)
Do While MyFile <> ""
For Each vItm In aWbks
If vItm & kExt = MyFile Then
Workbooks.Open Filename:=MyFolder & "\" & MyFile
Call UpdateAllSheets
Exit For
End If: Next
MyFile = Dir
Loop
End Sub
Can anyone please review code below and tell me where am I going wrong?
Basically what I am trying to achieve, user inputs name in the Column A, then will click upload button (same row, column F), excel would create a folder using name from Column A, via filedialog window user will select multiple files which should be copied to newly created folder, finally excel would also additionally create path to the folder (saved in column D) and stamp the date (column E).
Current problems:
Fails to copy multiple files, currently I can only copy one file
File is copied to parent folder of newly created folders, basically
fails to copy to newly created folder itself.
My code:
Sub Button1_Click()
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String
Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To openDialog.SelectedItems.Count
myfile = openDialog.SelectedItems.Item(i)
Next
If openDialog.Show = -1 Then
If Dir(Path & Foldername, vbDirectory) = "" Then
MkDir Path & Foldername
End If
objFSO.CopyFile myfile, Path
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")
MsgBox "Files were successfully copied"
End If
End Sub
Your For loop was in the wrong place. This is why you were not able to loop through every file and copy it.
You have this problem, because you used objFSO.CopyFile myfile, Path instead of the newly created folder name. I changed that part with this: objFSO.CopyFile myfile, Path & Foldername & "\" . Note that Path & Foldername is not enough, as you need to have \ at the end.
The working code:
Sub Button1_Click()
Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String
Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"
Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
If openDialog.Show = -1 Then
If Dir(Path & Foldername, vbDirectory) = "" Then
MkDir Path & Foldername
End If
For i = 1 To openDialog.SelectedItems.Count
myfile = openDialog.SelectedItems.Item(i)
objFSO.CopyFile myfile, Path & Foldername & "\"
Next
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")
MsgBox "Files were successfully copied"
End If
Set objFSO = Nothing
Set openDialog = Nothing
End Sub
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