Hi,
I have a marco set to run and pull some information from a series of workbooks (Which I was generously help out with in the thread below, thanks to Doc.AElstein). I have come across an issue with the structure of the folders in which the workbooks are kept, and need the macro to look in all subfolders for the files that I am after.
Post to create original macro:
http://www.excelforum.com/excel-prog...ml#post4208224
Code for Macro:
Sub Code4OpenCloseAllFilesIfChangedSinceLastTime()
' Date Stamp info
Dim DateLastModified As String 'This is the Date shown as last time file was saved.
Dim DateStamp As String 'This represents the Date this macro last ran and
' Workbooks Info.
Dim WB As Workbook, ws As Worksheet 'Variables used for temproary holding of File and sheet in each File looked at in Cressie Folder
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1") 'Sheet where date stamp is
Dim strFileName As String, FullFilePathAndName As String 'Variables for File Name and full Path Link to File
Dim strDefPath As String: Let strDefPath = "S:\NJR\SEC\MC\Test" 'Any Path / Folder to test this code! here we simply use the Path where the File with this code in is
Dim FileSystem As Object
Dim HostFolder As String
If Right(strDefPath, 1) <> "\" Then strDefPath = strDefPath & "\" 'Good check as this is sometimes forgotten
Debug.Print strDefPath 'Displaying the string in the Immediate Window (Ctrl-G in the VB Editor) can help to check correct format
'Initial ( First ) File in Folder
Let strFileName = Dir("" & strDefPath & "") 'Gives next ( Any type ) File in strDefPath Folder
Dim strExt As String 'Used to narrow down Files to specific type
Let strExt = "xls":
Dim strSearchForDir As String: Let strSearchForDir = strDefPath & "*." & strExt
Debug.Print strSearchForDir
Let strFileName = Dir("" & strSearchForDir & "") ' To be a bit more selective
Debug.Print strFileName '
Let DateStamp = ws1.Cells(1, 1).Value 'Date stamp in first cell of master File to indicate whan this macro last ran
'Main loop For each file in folder while...
While strFileName <> "" 'Dir will return this once it has gone through every file of Type and Folder selected in above lines
Debug.Print strFileName
If strFileName <> ThisWorkbook.Name Then 'Just in case this File is also in the Folder you are getting Files from
Let FullFilePathAndName = strDefPath & strFileName
Debug.Print FullFilePathAndName
Let DateLastModified = CStr(Format((FileDateTime(FullFilePathAndName)), "dd/mm/yyyy"))
'Check criteria for doing Stuff, then do or not
If DateStamp = "" Or DateLastModified > DateStamp Then ' case profgram vever run or a change since run Important to do the "" check first or the second could error due to incompatible types
Set WB = Workbooks.Open(strDefPath & Application.PathSeparator & strFileName) 'Will not error if File already open.
Set ws = WB.Worksheets.Item(1) 'First sheet item ( first from left tab )
Range("L3:W3").Copy
'If you change the above for a lot of lines, only lines with data will be pulled through
Application.DisplayAlerts = False
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 12)) ' Do the main stuff ( Replace this line with whatever you want to do
'wb.Close SaveChanges:=True 'Option stops automatically being asked so no need for Application.DisplayAlerts = False / True pair . And we want to save or the two date alterations will not be made
'Update Date Stamp after macro has dine stuff
ws1.Cells(1, 1).Value = CStr(Format(Now(), "dd/mm/yyyy")) 'Always use this Format by everyone to be on the safe side
ws1.Cells(1, 1).NumberFormat = "@" 'Bit of "Belt and Braces" for Excel and VBA Date change annoying characteristics
Else ' case File has not been updated
'MsgBox ("File " & strFileName & " has not been changed since " & DateStamp & "")
'Do no stuff so do not change date stamp
End If
Else 'case this workbook selected
End If
strFileName = Dir 'Using simple unqualified Dir goes to next File similar in type to the last in last Folder looked in ( Does the same again with the same search criteria )
Wend
End Sub
I have found code to look in subfolders and it works with some things I have tried, however I cannot get it to work with the above macro (using Call Code4OpenCloseAllFilesIfChangedSinceLastTime in the appropriate place. I am guessing that is is something to do with either conflicting filepaths or the dir command from the original macro, but cannot work it out.
code from here:
http://answers.microsoft.com/en-us/o...32ea68e?auth=1
that works with some things to look in the subfolders, but cannot get my macro from above to work. All help greatly appreciated!
Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder("S:\NJR\SEC\MC\Test\")
DoOneFolder FF
End Sub
Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WB As Workbook
Dim WBname As String
For Each F In FF.Files
Set WB = Workbooks.Open(F.Path)
Call Code4OpenCloseAllFilesIfChangedSinceLastTime
' do something with workbook WB here
WB.Close
Debug.Print F.Name
Next F
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub
Bookmarks