Check if files exist based on list of cell values - excel

I need to check if a list of files exist in a certain directory, based on cell values in Excel.
If some files are not found, a message box displays the names of the files that were not found.

I'm unclear if you want to see the files listed in the range that do not appear in the folder or if you want to see the files in the folder that are not in the range.
The following example lists the files in the range that are not in the folder.
I've set up a page for the example, so you may need to adjust your sheet to match, or adjust your code to fit your sheet. Be sure that the folder path you put in B1 has the trailing backslash.
Here's the code:
Sub files_in_folder()
Dim folder As String
Dim filename As String
Dim filenames As Range
Dim cell As Range
Dim s As Worksheet
Dim missing As New Collection
Dim message As String
Dim x As Integer
Set s = ActiveSheet
folder = s.Range("b1").Value
Set filenames = Range(s.Range("b2"), s.Range("b2").End(xlDown))
For Each cell In filenames
If Dir(folder + cell.Value) = "" Then missing.Add cell.Value
Next
If missing.Count = 0 Then
message = "All files were found in " & folder
Else
message = "The following files were not found in " & folder & vbNewLine
For x = 1 To missing.Count
message = message + " " + missing(x) & vbNewLine
Next
End If
MsgBox message
End Sub

Try this.
Sub TestListFilesInFolder()
' Open folder selection
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
If Right(pPath, 1) <> "\" Then
pPath = pPath & "\"
End If
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the file list
' add headers
ActiveSheet.Name = "ListOfFiles"
With Range("A2")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File Name:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("A3:F3").Font.Bold = True
Worksheets("ListOfFiles").Range("A1").Value = pPath
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
' list all files included subfolders
Range("A3").Select
Lastrow = Range("A1048576").End(xlUp).Row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
"B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ListOfFiles").Sort
.SetRange Range("A3:F" & Lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
NextCode:
MsgBox "No files Selected!!"
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A1048576").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path & FileItem.Name
Cells(r, 2).Formula = (FileItem.Size / 1048576)
Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
' use file methods (not proper in this example)
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:F").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Result:

Related

How to write rows with the file name in Column A to CSV files?

I am trying to generate CSV files from a set of records from Excel.
Column A is the file name and the rest of the columns are the data to write to the the file.
As of now, I am using WriteLine, but it doesn't work as expected:
As you can see, I don't get the expected output. How do I get the expected output?
Private Sub ommandButton1_Click()
Dim Path As String
Dim Folder As String
Dim Answer As VbMsgBoxResult
Path = "C:\Access Permissions\Users"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
'-------------Create Folder -----------------------
MkDir ("C:\Access Permissions")
MkDir ("C:\Access Permissions\Roles")
MkDir ("C:\Access Permissions\Users")
Else
Set rngSource = Range("A4", Range("A" & Rows.Count).End(xlUp))
rngSource.Copy Range("AA1")
Range("AA:AA").RemoveDuplicates Columns:=1, Header:=xlNo
Set rngUnique = Range("AA1", Range("AA" & Rows.Count).End(xlUp))
Set lr = Cells(rngSource.Rows.Count, rngSource.Column)
Set fso = CreateObject("Scripting.FileSystemObject")
For Each cell In rngUnique
n = Application.CountIf(rngSource, cell.Value)
Set C = rngSource.Find(cell.Value, lookat:=xlWhole, after:=lr)
Set oFile = fso.CreateTextFile("C:\Access Permissions\Users\" & cell.Value & "-Users.csv")
For i = 1 To n
oFile.WriteLine C.Offset(0, 1).Value
oFile.WriteLine C.Offset(0, 2).Value
oFile.WriteLine C.Offset(0, 3).Value
oFile.WriteLine C.Offset(0, 4).Value
oFile.WriteLine C.Offset(0, 6).Value
oFile.WriteLine C.Offset(0, 7).Value
Set C = rngSource.FindNext(C)
Next i
Next cell
rngUnique.ClearContents
MsgBox "Individual Users.csv files got generated" & vbCrLf & " " & vbCrLf & "Path - C:\Access Permissions\Groups "
End If
End Sub
Updated Image:
Let me re-phrase my questions.
Updated Image Enclosed.
Using the Data Set [Updated Image point 1], It creates unique CSV files based on column A.
File got saved at the path given.
As of now the row data associated with each file name got written in the files but in a new line manner.
As expected, how the output can be written in Columns.[ Updated Image Point 4]
Given code is working without any error.
5.1. I just need to click twice if the Path folder does not exist.
5.2. at first click, it creates the Folder at the given path.
5.3. at Second click it generates the unique files, with its records.
If you can please guide me on how the records can be written in columns [ Updated Image Point 4 ], expected output.
Download File
I assume your data does not contain any semicolons.
You are writing each field on a line by itself. Instead, join the fields on a single line:
oFile.WriteLine C.Offset(0, 1).Value & ";" & _
C.Offset(0, 2).Value & ";" & _
C.Offset(0, 3).Value & ";" & _
C.Offset(0, 4).Value & ";" & _
C.Offset(0, 6).Value & ";" & _
C.Offset(0, 7).Value
There are other bugs in your example; it should not work as far as I can see. For example, you keep opening the same file with CreateTextFile. You should only create a file once, not every time you write to it. According to the documentation, you should get an error on your second try, see CreateTextFile method. The reason you don't get an error is probably because you never close the file. You should close the files you create.
I would use this approach instead:
' Collect the data for each file into a dictionary.
' The cells in the table must not contain semicolons.
Sub Doit()
Dim Sht As Worksheet
Dim Rng As Range
Dim LastRowNum As Long, LastColNum As Long
Dim Lst As Variant, Hdr As Variant, Elem As Variant
Dim Idx As Long, Idx2 As Long
Dim Dct As Object
Dim HdrTxt, Txt As String, Sep As String
Dim Filename As String
Set Sht = ActiveSheet
' Get the last row in column 1
Set Rng = Sht.Cells(Sht.Rows.Count, 1).End(xlUp)
LastRowNum = Rng.Row
' Get the last column in row 3
Set Rng = Sht.Cells(3, Sht.Columns.Count).End(xlToLeft)
LastColNum = Rng.Column
' Get the headers in row 3
Set Rng = Sht.Range(Sht.Cells(3, 1), Sht.Cells(3, LastColNum))
Hdr = Rng
' Create a semicolon seprated line for the headers
HdrTxt = ""
Sep = ""
For Idx = LBound(Hdr, 2) To UBound(Hdr, 2)
HdrTxt = HdrTxt & Sep & Hdr(1, Idx)
Sep = ";"
Next Idx
HdrTxt = HdrTxt & vbNewLine
' Get the data from row 4 and down
Set Rng = Sht.Range(Sht.Cells(4, 1), Sht.Cells(LastRowNum, LastColNum))
Lst = Rng
' Store the data for each file in a dicitonary
Set Dct = CreateObject("Scripting.Dictionary")
For Idx = LBound(Lst) To UBound(Lst)
Filename = Lst(Idx, 1)
' Create a semicolon seprated line
Txt = ""
Sep = ""
For Idx2 = LBound(Lst, 2) To UBound(Lst, 2)
Txt = Txt & Sep & Lst(Idx, Idx2)
Sep = ";"
Next Idx2
Txt = Txt & vbNewLine
' Add the line to the dictionary
If Dct.Exists(Filename) Then
Dct(Filename) = Dct(Filename) & Txt
Else
Dct(Filename) = HdrTxt & Txt
End If
Next Idx
' Output data for each file to the immdiate window
For Each Elem In Dct
' Change this to open the file and write the contents
Debug.Print "---- Filename: " & Elem
Debug.Print Dct(Elem)
Next Elem
End Sub
The example makes sure you only create the files once:
Change the last loop For Each Elem In Dct that prints the data to the immediate window, to create a file instead. Use the Write method instead of the WriteLine method, as the data already contains the line-breaks. And remember to Close the files.
I think this is what you want.
Sub Copy_To_Workbooks()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim MyPath As String
Dim foldername As String
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:B" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new workbook"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Set the file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".txt": FileFormatNum = -4143
Else
'You use Excel 2007-2010
If ActiveWorkbook.FileFormat = 56 Then
FileExtStr = ".txt": FileFormatNum = 56
Else
FileExtStr = ".txt": FileFormatNum = 51
End If
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Delete the sheet RDBLogSheet if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("RDBLogSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
ws2.Name = "RDBLogSheet"
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = "C:\Users\ryans\OneDrive\Desktop\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A3"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A4:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Copy/paste the visible data to the new workbook
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
On Error Resume Next
ChDir MyPath
ActiveWorkbook.SaveAs Filename:= _
foldername & cell.Value & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
If Err.Number > 0 Then
Err.Clear
ErrNum = ErrNum + 1
WSNew.Parent.SaveAs foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
.Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
.Cells(cell.Row, "A").Interior.Color = vbRed
Else
.Cells(cell.Row, "B").Formula = _
"=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
End If
WSNew.Parent.Close False
On Error GoTo 0
End If
'Show all the data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
.Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
.Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
.Cells(3, "A").Value = "Unique Values"
.Cells(3, "B").Value = "Full Path and File name"
.Cells(3, "A").Font.Bold = True
.Cells(3, "B").Font.Bold = True
.Columns("A:B").AutoFit
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
ws2.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Before:
After:

Get File list from folders and subfolders Excel VBA

I already have a script that gets list of file in a folder but I need to include subfolders as well, can you please help me modify this, I have tried to compile something from the answers found here but failed.
Sub getfiles()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel reports")
For Each oFile In oFolder.Files
If oFile.DateLastModified > Now - 7 Then
Cells(i + 1, 1) = oFolder.Path
Cells(i + 1, 2) = oFile.Name
Cells(i + 1, 3) = "RO"
Cells(i + 1, 4) = oFile.DateLastModified
i = i + 1
End If
Next oFile
Here's a non-recursive method:
Sub getfiles()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object, sf
Dim i As Integer, colFolders As New Collection, ws As Worksheet
Set ws = ActiveSheet
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder("C:\Users\cirklta\Desktop\excel")
colFolders.Add oFolder 'start with this folder
Do While colFolders.Count > 0 'process all folders
Set oFolder = colFolders(1) 'get a folder to process
colFolders.Remove 1 'remove item at index 1
For Each oFile In oFolder.Files
If oFile.DateLastModified > Now - 7 Then
ws.Cells(i + 1, 1) = oFolder.Path
ws.Cells(i + 1, 2) = oFile.Name
ws.Cells(i + 1, 3) = "RO"
ws.Cells(i + 1, 4) = oFile.DateLastModified
i = i + 1
End If
Next oFile
'add any subfolders to the collection for processing
For Each sf In oFolder.subfolders
colFolders.Add sf
Next sf
Loop
End Sub
Here's a much simpler and faster method. This should write all the results in a text file and all you have to do is to open that file and read its contents.
Sub List_All_Files_And_SubFolders()
PID = Shell("cmd /k dir c:\test /s /b > c:\test\all_files.txt", vbHide)
While IsFileInUse() = True: DoEvents: Wend
End Sub
Function IsFileInUse()
On Error GoTo Error_Handeling
IsFileInUse = True
Name "c:\test\all_files.txt" As "c:\test\all_files1.txt"
Name "c:\test\all_files1.txt" As "c:\test\all_files.txt"
IsFileInUse = False
Error_Handeling:
If Err.Description = "Path/File access error" Then IsFileInUse = True: Exit Function
End Function
You can do it this way.
Sub FileListingAllFolder()
' Open folder selection
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
If Right(pPath, 1) <> "\" Then
pPath = pPath & "\"
End If
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the file list
' add headers
ActiveSheet.Name = "ListOfFiles"
With Range("A2")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File Name:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("A3:F3").Font.Bold = True
Worksheets("ListOfFiles").Range("A1").Value = pPath
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
' list all files included subfolders
Range("A3").Select
Lastrow = Range("A1048576").End(xlUp).Row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
"B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ListOfFiles").Sort
.SetRange Range("A3:F" & Lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
NextCode:
MsgBox "No files Selected!!"
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A1048576").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path & FileItem.Name
Cells(r, 2).Formula = (FileItem.Size / 1048576)
Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
' use file methods (not proper in this example)
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:F").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Under Tools, set a reference to 'Microsoft Scripting Runtime'.
#Tadas: "...but somehow it doesn't even show up as a macro and I can not run it."
Try declaring the sub as Public, e.g. Public Sub FileListingAllFolder() .
Private subs and private functions do not show up in the Macros list.
I became motivated to provide for myself with a kind of universal function which returns a collection of folder objects plus optionally all sub-folders all in ascending order. The collection then may be used for any purpose just by looping through the collection. The function looks as follows:
Public Function Folders(Optional ByVal fo_spec As String = vbNullString, _
Optional ByVal fo_subfolders As Boolean = False, _
Optional ByRef fo_result As String) As Collection
' ----------------------------------------------------------------------------
' Returns all folders in a folder (fo_spec) - optionally including all
' sub-folders (fo_subfolders = True) - as folder objects in ascending order.
' When no folder (fo_spec) is provided a folder selection dialog request one.
' When the provided folder does not exist or no folder is selected the
' the function returns with an empty collection. The provided or selected
' folder is returned (fo_result).
' ----------------------------------------------------------------------------
Static cll As Collection
Static Queue As Collection ' FiFo queue for folders with sub-folders
Static Stack As Collection ' LiFo stack for recursive calls
Static foStart As Folder
Dim aFolders() As Variant
Dim fl As File
Dim flStart As Folder
Dim fo1 As Folder
Dim fo2 As Folder
Dim fso As New FileSystemObject
Dim i As Long
Dim j As Long
Dim s As String
Dim v As Variant
If cll Is Nothing Then Set cll = New Collection
If Queue Is Nothing Then Set Queue = New Collection
If Stack Is Nothing Then Set Stack = New Collection
If Queue.Count = 0 Then
'~~ Provide the folder to start with - when not provided by fo_spec via a selection dialog
If fo_spec <> vbNullString Then
If Not fso.FolderExists(fo_spec) Then
fo_result = fo_spec
GoTo xt
End If
Set fo1 = fso.GetFolder(fo_spec)
Else
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the desired folder!"
.InitialFileName = CurDir
.AllowMultiSelect = False
If .Show <> -1 Then GoTo xt
Set fo1 = fso.GetFolder(.SelectedItems(1))
End With
End If
Set foStart = fo1
Else
'~~ When recursively called (Queue.Count <> 0) take first sub-folder queued
Set fo1 = Queue(1)
End If
For Each fo2 In fo1.SubFolders
cll.Add fo2
If fo1.SubFolders.Count <> 0 And fo_subfolders Then
Queue.Add fo2
End If
Next fo2
Stack.Add cll ' stack result in preparation for the function being called resursively
If Queue.Count > 0 Then
Queue.Remove 1
End If
If Queue.Count > 0 Then
Folders Queue(1).Path ' recursive call for each folder with subfolders
End If
xt: Set fso = Nothing
If Stack.Count > 0 Then
Set cll = Stack(Stack.Count)
Stack.Remove Stack.Count
End If
If Stack.Count = 0 Then
If cll.Count > 0 Then
'~~ Unload cll to array, when fo_subfolders = False only those with a ParentFolder foStart
ReDim aFolders(cll.Count - 1)
For Each v In cll
aFolders(i) = v
i = i + 1
Next v
'~~ Sort array from A to Z
For i = LBound(aFolders) To UBound(aFolders)
For j = i + 1 To UBound(aFolders)
If UCase(aFolders(i)) > UCase(aFolders(j)) Then
s = aFolders(j)
aFolders(j) = aFolders(i)
aFolders(i) = s
End If
Next j
Next i
'~~ Transfer array as folder objects to collection
Set cll = New Collection
For i = LBound(aFolders) To UBound(aFolders)
Set fo1 = fso.GetFolder(aFolders(i))
cll.Add fo1
Next i
End If
Set Folders = cll
If Not foStart Is Nothing Then fo_result = foStart.Path
End If
Set cll = Nothing
End Function
The function had been tested as follows:
Private Sub Folders_Test()
Const TEST_FOLDER = "E:\Ablage\Excel VBA\DevAndTest"
Dim v As Variant
Dim cll As Collection
Dim s As String
Dim sStart As String
Set cll = Folders("c:\XXXX", True, sStart)
s = "1. Test: Folders in a provided non-existing folder ('" & sStart & "')"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
Debug.Assert cll.Count = 0
Set cll = Folders(TEST_FOLDER, , sStart)
s = "2. Test: Folders in the provided folder '" & sStart & "' (without sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(TEST_FOLDER, True, sStart)
s = "3. Test: Folders in the provided folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
Set cll = Folders(, True, sStart)
s = "4. Test: Folders in the manually selected folder '" & sStart & "' (including sub-folders):"
Debug.Print vbLf & s
Debug.Print String(Len(s), "-")
For Each v In cll
Debug.Print v.Path
Next v
End Sub

how to save a file in the same directory as the macro is saved

this is my code
Sub teste3()
' Application.ScreenUpdating = False
Dim car As Variant Dim caminho As String
ReDim car(1 To 4)
Set b = ThisWorkbook.ActiveSheet
For i = 4 To 100000
If b.Cells(i, 9) = Empty Then Exit For
' Number of columns in the staging area
car(1) = b.Cells(i, 9)
car(2) = b.Cells(i, 10)
car(3) = b.Cells(i, 12)
car(4) = b.Cells(i, 14)
Range("B16").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = car(3)
Range("B17").Select
Range("B17").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = car(4)
Range("B18").Select
Dim oWs As Worksheet Dim oRng As Range Dim oChrtO As ChartObject Dim
lWidth As Long, lHeight As Long
Set oWs = ActiveSheet
Set oRng = oWs.Range("A1:F13")
oRng.CopyPicture xlScreen, xlPicture
lWidth = oRng.Width lHeight = oRng.Height
Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth,
Height:=lHeight)
oChrtO.Activate With oChrtO.Chart
.Paste
'.sa Filename:=EstaPastaDeTrabalho.Path & car(1) & "_" & Replace(car(2), "/", "_") & "_Barr_" & car(3) * 100 & "_cup_" & car(4)
* 100 & ".jpg"
.Export Filename:=ThisWorkbook.Path & car(1) & "_" & Replace(car(2), "/", "_") & "_Barr_" & car(3) * 100 & "_cup_" & car(4)
* 100 & ".jpg"
'Set down 1 row from present location End With
oChrtO.Delete
Next i
'With Application ' ' .ScreenUpdating = True ' .DisplayAlerts = True ' .Calculation = xlCalculationAutomatic
End Sub
but the file is not saving in my directory, hi is saving a pasth before this, how can I do this code better?
I need him to save these files in the folder where the macro is saved, but I can't put the name of the folder because I want to change it from the folder and make it keep saving only in the name folder, without me changing the name

VBA changes from a cell

To explain my title, basically i have a macro code which ill display in sec that is requesting number of days that need it to be exported from our shared mailbox. Now on a daily basis I have to change the number of days we need to export and is getting really frustrating. The following line is in question:
If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= 10 Then
That number 10 needs to change on a daily basis so i tried with active cell but no success as i get a runtime error 438.
So my question is: Is there a way that in a separated spreadsheet to input the number of days i need to export and that line in question can take the information from there and carry on with the code ?
Please see full code below.
Sub Accomplished()
Application.Run "Module5.OptimizeCode_Begin"
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name As String
Dim vItems As Outlook.Items
Dim vItem As Object
'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailBoxName = "Castle Donington Time and Attendance"
'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Accomplished" 'Sample "Inbox" or "Sent Items"
'To directly a Folder at a high level
'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)
'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder
Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If
'Read Through each Mail and export the details to Excel for Email Archival
ThisWorkbook.Sheets(3).Activate
Folder.Items.sort "Received"
'Insert Column Headers
ThisWorkbook.Sheets(3).Cells(1, 1) = "Sender"
ThisWorkbook.Sheets(3).Cells(1, 2) = "Subject"
ThisWorkbook.Sheets(3).Cells(1, 3) = "Date"
ThisWorkbook.Sheets(3).Cells(1, 4) = "Sent"
ThisWorkbook.Sheets(3).Cells(1, 5) = "EmailID"
ThisWorkbook.Sheets(3).Cells(1, 6) = "Categories"
ThisWorkbook.Sheets(3).Cells(1, 7) = "Parent"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"
'Export eMail Data from PST Folder
oRow = 1
Set vItems = Folder.Items
For iRow = 1 To vItems.Count
Set vItem = vItems.Item(iRow)
If vItem.Class = 43 Then
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= 10 Then
oRow = oRow + 1
ThisWorkbook.Sheets(3).Cells(oRow, 1).Select
ThisWorkbook.Sheets(3).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(3).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(3).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(3).Cells(oRow, 4) = Folder.Items.Item(iRow).SentOn
ThisWorkbook.Sheets(3).Cells(oRow, 5) = Folder.Items.Item(iRow).ConversationID
ThisWorkbook.Sheets(3).Cells(oRow, 6) = Folder.Items.Item(iRow).Categories
ThisWorkbook.Sheets(3).Cells(oRow, 7) = Folder.Items.Item(iRow).Parent
'ThisWorkbook.Sheets(3).Cells(oRow, 8) = Folder.Items.Item(iRow).Sent
'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
End If
End If
Next iRow
MsgBox "Extration Complete ^.^"
Set Folder = Nothing
Set sFolders = Nothing
' sheet3_copypaste Macro
Sheets("Sheet3").Select
ActiveWindow.SmallScroll Down:=-33
Range("A2:H3001").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Full List").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Format
Sheets("Full List").Select
Columns("D:E").Select
Selection.NumberFormat = "m/d/yyyy h:mm"
Range("D1").Select
' sort Macro
Range("D6").Select
ActiveWorkbook.Worksheets("Full List").sort.SortFields.Clear
ActiveWorkbook.Worksheets("Full List").sort.SortFields.Add Key:=Range("D6"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Full List").sort
.SetRange Range("A5:I4976")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("D1").Select
End_Lbl1:
Application.Run "Module5.OptimizeCode_End"
End Sub
Thank you for taking interest.
Any questions i'm happy to answer
Just for consistency sake with excel and macros a workbook is a full xlsm file that contains a collection of worksheets (individual tabs that you put data on). By a seperated spreadsheet I'm assuming a different workbook.
Here is some useful code for getting data from a spreadsheet.
The main function GetData at the bottom, instead of storing the data in a local cell you would just put it in a variable and use that in your "<" statement.
Sub GetDataDemo()
Dim FilePath$, Row&, Column&, Address$
'change constants & FilePath below to suit
'***************************************
Const FileName$ = "Book1.xls"
Const SheetName$ = "Sheet1"
Const NumRows& = 10
Const NumColumns& = 10
FilePath = ActiveWorkbook.Path & "\"
'***************************************
DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
For Row = 1 To NumRows
For Column = 1 To NumColumns
Address = Cells(Row, Column).Address
Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
Columns.AutoFit
Next Column
Next Row
ActiveWindow.DisplayZeros = False
End Sub
Private Function GetData(Path, File, Sheet, Address)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
Range(Address).Range("A1").Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function
If its from the same workbook you would just use something like
dim NUMDAYS as double
NUMDAYS = sheets("sheet2").range("A1").value to assign to a variable which would be used later in your macro.
If VBA.DateValue(VBA.Now) - VBA.DateValue(vItem.ReceivedTime) <= NUMDAYS Then

How to auto populate a single spreadsheet from multiple spreadsheets

I have a set of Excel spreadsheets to summarise. My sheets are numbered:
xxx-yy-zzzz; xxx-yy-zzz+1; etc.
I would like a reporting spreadsheet to retrieve information each time it is opened. I don't mind doing it with VBA or with formulae.
I've the macro below. I need to auto increment until it runs out of spreadsheets. All the files will be in the same folder, this file can be in any folder.
Sub Macro1()
'
' Macro1 Macro
' autopop
'
'
Range("C4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R4C5"
Range("D4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R5C3"
Range("E4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Order'!R27C9"
Range("F4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R8C9"
End Sub
Siddharth's method above worked very well for when we were using very simple file names, but it got a lot harder when there were additions made to the filename... So i did some surfing and found a basis of a "list all files and put them in a worksheet" and using some of the code from Siddharth's answer above (thank you very much Mr. Siddharth) and the example i found online here http://alanmurray.blogspot.com/2013/08/excel-vba-list-all-excel-files-in-folder.html , i have finalised my code, and my little VBA app now does what i want - it opens a folder and goes through and pulls out particular cells and creates a summary report in seconds -> will save me hours of tedious work...
Code:
Sub ImportFileList()
Dim MyFolder As String 'Store the folder selected by the using
Dim FiletoList As String 'store the name of the file ready for listing
Dim NextRow As Long 'Store the row to write the filename to
On Error Resume Next
Application.ScreenUpdating = False
'Display the folder picker dialog box for user selection of directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
'Dir finds the first Excel workbook in the folder
FiletoList = Dir(MyFolder & "*.xls")
Range("A1").Value = "Filename"
Range("B1").Value = "Purchase Order Number"
Range("C1").Value = "Vendor"
Range("D1").Value = "Date of PO"
Range("E1").Value = "Currency"
Range("F1").Value = "Subtotal"
Range("G1").Value = "VAT"
Range("H1").Value = "Total"
Range("A1:H1").Font.Bold = True
'Find the next empty row in the list
NextRow = Application.CountA(Range("A:A")) + 1
NextRow = NextRow + 1 ' skip a line
'Do whilst the dir function returns an Excel workbook
Do While FiletoList <> ""
Cells(NextRow, 1).Value = FiletoList 'Write the filename into the next available cell
Cells(NextRow, 2).Formula = "='[" & FiletoList & "]Cover'!R4C4" ' Cover is the excel sheet name
Cells(NextRow, 3).Formula = "='[" & FiletoList & "]Cover'!R6C3"
Cells(NextRow, 4).Formula = "='[" & FiletoList & "]Cover'!R4C7"
Cells(NextRow, 5).Formula = "='[" & FiletoList & "]Cover'!R21C4"
Cells(NextRow, 6).Formula = "='[" & FiletoList & "]Cover'!R19C5"
Cells(NextRow, 7).Formula = "='[" & FiletoList & "]Cover'!R20C5"
Cells(NextRow, 8).Formula = "='[" & FiletoList & "]Cover'!R21C5"
NextRow = NextRow + 1 'Move to next row
FiletoList = Dir 'Dir returns the next Excel workbook in the folder
Loop
Application.ScreenUpdating = True
End Sub
Is this what you are trying? (UNTESTED)
'~~> Change this to the directory which has .xlsx files
Const sDir = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim i As Long, num As Long, Calcmode As Long
Dim FilesCount As Long, startNum As Long
On Error GoTo Whoa
Set ws = ThisWorkbook.Sheets("Sheet1")
With Application
.ScreenUpdating = False
Calcmode = .Calculation
.Calculation = xlCalculationManual
End With
'~~> Get the number of files in that directory
FilesCount = getFileCount(sDir)
startNum = 1
If FilesCount <> 0 Then
With ws
For i = 4 To (FilesCount + 3)
num = Format(startNum, "000")
.Range("C" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R4C5"
.Range("D" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R5C3"
.Range("E" & i).Formula = "='[413-05-" & num & ".xlsx]Order'!R27C9"
.Range("F" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R8C9"
startNum = startNum + 1
Next i
End With
End If
LetsContinue:
With Application
.ScreenUpdating = True
.Calculation = Calcmode
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Function getFileCount(s As String) As Long
Dim Path As String, Filename As String
Dim Count As Long
Path = s & "*.xlsx"
Filename = Dir(Path)
Do While Filename <> ""
Count = Count + 1
Filename = Dir()
Loop
getFileCount = Count
End Function

Resources