I have script to scan a folder for files with a file name containing a certain text. The script works but it stops after sometime without finishing the scan of the complete folder (I reached 16663 scans, is there a limit?). I can't figure out why the script stops. Any help is greatly appreciated.
I initially used the code posted in this post Get list of sub-directories in VBA
Update: The drive I'm scanning is a network drive. My assumption now is that due to a hick-up in the connection the script stops. At the moment I'm trying different approaches to work around this...
Sub LoopThroughFilePaths()
Application.StatusBar = True
Application.ScreenUpdating = False
Counter = 1
Dim strPath As String
strPath = "V:\50" ' folder to scan
Dim myArr
myArr = GetSubFolders(strPath)
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Used Function GetSubFolders
Function GetSubFolders(RootPath As String)
Application.ScreenUpdating = False
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Dim output As String
Dim StrFileOut As String
VAR_01_output = "D:\output" 'Location to copy found files to
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
Dim StrFile As String
StrFile = Dir(fld + "\*labsuite*") 'wild card search for files
Do While Len(StrFile) > 0
StrFileOut = Format(Now(), "hh-mm-ss") & "_" & StrFile ' rename files
FileCopy fld + "\" + StrFile, VAR_01_output + "\" + StrFileOut 'copy found files to output folder
StrFile = Dir
Loop
For Each sf In fld.SubFolders
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
Counter = Counter + 1
On Error Resume Next
myArr = GetSubFolders(sf.Path)
On Error Resume Next
'ActiveWorkbook.Sheets(1).Cells(1, 1).Value = Counter
Application.StatusBar = sf.Path
DoEvents
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
Related
I am trying to extract some data from a series of zip files and store them in the same sheet I'm working on. I have already extract name of each zip file and store them in one column of the sheet. I want to loop through them to extract data I need, however, I keep getting error of "run time error 91" when I access the oApp.Namespace(zipName).Items. Here is the VBA code I have, can anyone help me with that? Thanks!
Sub GetData()
Dim iRow As Integer 'row counter
Dim iCol As Integer 'column counter
Dim savePath As String 'place to save the extracted files
Dim fileContents As String 'contents of the file
Dim fso As FileSystemObject 'FileSystemObject to work with files
iRow = 1 'start at first row
iCol = 1 'start at frist column
'set the save path to the temp folder
savePath = Environ("TEMP")
'create the filesystem object
Set fso = New FileSystemObject
Do While ActiveSheet.Cells(iRow, iCol).Value <> ""
fileContents = fso.OpenTextFile(UnzipFile(savePath, ActiveSheet.Cells(iRow, iCol).Value, "Device-1_IR_VR_7-16-2019-2-32-55_PM.pda-iv.txt"), ForReading).ReadAll
ActiveSheet.Cells(iRow, iCol).Value = fileContents
iRow = iRow + 1
Loop
'free the memory
Set fso = Nothing
End Sub
Function UnzipFile(savePath As String, zipName As String, fileName As String) As String
Dim oApp As Shell
Dim strFile As String
'get a shell object
Set oApp = CreateObject("Shell.Application")
'check to see if the zip contains items
'Debug.Print oApp.Namespace(zipName).Items.Count
If Not IsNull(oApp.Namespace(zipName).Items) Then
If oApp.Namespace(zipName).Items.Count > 0 Then
Dim i As Integer
'loop through all the items in the zip file
For i = 0 To oApp.Namespace(zipName).Items.Count - 1
'check to see if it is the txt file
If UCase(oApp.Namespace(zipName).Items.Item(i)) = UCase(fileName) Then
'save the files to the new location
oApp.Namespace(savePath).CopyHere oApp.Namespace(zipName).Items.Item(i)
'set the location of the file
UnzipFile = savePath & "\" & fileName
'exit the function
Exit Function
End If
Next i
End If
End If
'free memory
Set oApp = Nothing
End Function
Swap your variables to Variant if they're going to be passed to Shell:
Sub GetData()
Dim iRow As Long 'row counter
Dim iCol As Long 'column counter
Dim savePath As Variant 'place to save the extracted files
Dim zipName As Variant
Dim txtPath As String
Dim fileContents As String 'contents of the file
Dim fso As FileSystemObject 'FileSystemObject to work with files
iRow = 1 'start at first row
iCol = 1 'start at first column
savePath = Environ("TEMP") 'set the save path to the temp folder
Set fso = New FileSystemObject 'create the filesystem object
Do While ActiveSheet.Cells(iRow, iCol).Value <> ""
zipName = ActiveSheet.Cells(iRow, iCol).Value
txtPath = UnzipFile(savePath, zipName, "Device-1_IR_VR_7-16-2019-2-32-55_PM.pda-iv.txt")
If Len(txtPath) > 0 Then 'if found the file...
fileContents = fso.OpenTextFile(txtPath, ForReading).ReadAll
ActiveSheet.Cells(iRow, iCol).Value = fileContents
End If
iRow = iRow + 1
Loop
End Sub
Function UnzipFile(savePath As Variant, zipName As Variant, fileName As String) As String
Dim oApp As Object, ns As Object, i As Long
Set oApp = CreateObject("Shell.Application") 'get a shell object
Set ns = oApp.Namespace(zipName) 'get the zip namespace
If ns.Items.Count > 0 Then
For i = 0 To ns.Items.Count - 1
'check to see if it is the txt file
If UCase(ns.Items.Item(i)) = UCase(fileName) Then
'save the files to the new location
oApp.Namespace(savePath).CopyHere ns.Items.Item(i)
UnzipFile = savePath & "\" & fileName 'return the location of the file
Exit Function
End If
Next i
End If
End Function
I have a folder containing about 500-600 excel files from a script I have made where the file names end up like this
101a12345.xlsx
101a67899.xlsx
102a12345.xlsx
102a78999.xlsx
The file names follow that patern, 101a, 102a etc. What i want to do is merge those based on that paternt into 1 excel file. Therefore, the 101a12345.xlsx and 101a67899.xlsx should merge into an 101aMaster.xlsx. All excel files are single sheet.
I have found a sample code here which i am trying to implement: How to merge multiple workbooks into one based on workbooks names
Taken from the link above:
Sub test(sourceFolder As String, destinationFolder As String)
Const TO_DELETE_SHEET_NAME As String = "toBeDeleted"
'------------------------------------------------------------------
Dim settingSheetsNumber As Integer
Dim settingDisplayAlerts As Boolean
Dim dict As Object
Dim wkbSource As Excel.Workbook
Dim wks As Excel.Worksheet
Dim filepath As String
Dim code As String * 4
Dim wkbDestination As Excel.Workbook
Dim varKey As Variant
'------------------------------------------------------------------
'Change [SheetsInNewWorkbook] setting of Excel.Application object to
'create new workbooks with a single sheet only.
With Excel.Application
settingDisplayAlerts = .DisplayAlerts
settingSheetsNumber = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
.DisplayAlerts = False
End With
Set dict = VBA.CreateObject("Scripting.Dictionary")
filepath = Dir(sourceFolder)
'Loop through each Excel file in folder
Do While filepath <> ""
If VBA.Right$(filepath, 5) = ".xlsx" Then
Set wkbSource = Excel.Workbooks.Open(sourceFolder & filepath)
Set wks = wkbSource.Worksheets(1)
code = VBA.Left$(wkbSource.Name, 4)
'If this code doesn't exist in the dictionary yet, add it.
If Not dict.exists(code) Then
Set wkbDestination = Excel.Workbooks.Add
wkbDestination.Worksheets(1).Name = TO_DELETE_SHEET_NAME
Call dict.Add(code, wkbDestination)
Else
Set wkbDestination = dict.Item(code)
End If
Call wks.Copy(Before:=wkbDestination.Worksheets(1))
wkbDestination.Worksheets(1).Name = VBA.Mid$(filepath, 6)
Call wkbSource.Close(False)
End If
filepath = Dir
Loop
'Save newly created files.
For Each varKey In dict.keys
Set wkbDestination = dict.Item(varKey)
'Remove empty sheet.
Set wks = Nothing
On Error Resume Next
Set wks = wkbDestination.Worksheets(TO_DELETE_SHEET_NAME)
On Error GoTo 0
If Not wks Is Nothing Then wks.Delete
Call wkbDestination.SaveAs(Filename:=destinationFolder & varKey & ".xlsx")
Next varKey
'Restore Excel.Application settings.
With Excel.Application
.DisplayAlerts = settingDisplayAlerts
.SheetsInNewWorkbook = settingSheetsNumber
End With
End Sub
However, this code opens all workbooks and at about 60-70 open excel files i receive an error: Run-time Error '1004' - Method 'Open' of object 'Workbooks' failed.
is there a way to make this code work?
Excel version is pro plus 2016.
Merge Workbooks
It will open the first of each files starting with the unique first four characters, and copy the first worksheet of each next opened file to the first opened file and finally save it as a new file.
There need not be only 2 files (starting with the same four characters) and there can only be one.
Adjust the values in the constants section.
Option Explicit
Sub mergeWorkbooks()
Const sPath As String = "F:\Test\2021\67077087\"
Const sPattern As String = "*.xlsx"
Const dPath As String = "F:\Test\2021\67077087\Destination\"
Const dName As String = "Master.xlsx"
Const KeyLen As Long = 4
Dim PatLen As Long: PatLen = Len(sPattern)
Dim fName As String: fName = Dir(sPath & sPattern)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Do While Len(fName) > 0
dict(Left(fName, KeyLen)) = Empty
fName = Dir
Loop
Application.ScreenUpdating = False
On Error Resume Next
MkDir dPath
On Error GoTo 0
Dim wb As Workbook
Dim Key As Variant
Dim wsLen As Long
For Each Key In dict.Keys
Set wb = Nothing
fName = Dir(sPath & Key & sPattern)
Do While Len(fName) > 0
wsLen = Len(fName) - PatLen - KeyLen + 2
If wb Is Nothing Then
Set wb = Workbooks.Open(sPath & fName)
wb.Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
'Debug.Print wb.Name
Else
With Workbooks.Open(sPath & fName)
'Debug.Print .Name
.Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
.Worksheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
.Close False
End With
End If
fName = Dir
Loop
Application.DisplayAlerts = False
wb.SaveAs dPath & Key & dName ', xlOpenXMLWorkbook
Application.DisplayAlerts = True
wb.Close False
Next Key
Application.ScreenUpdating = True
End Sub
Test for Names
Use the following to print all names in the active workbook to the VBE Immediate window (CTRL+G).
Sub listNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
Debug.Print nm.Name
Next nm
End Sub
First, check if the names (if any) are used in some formulas.
Use the following to delete all names in the active workbook.
Sub deleteNames()
Dim nm As Name
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
End Sub
Untested but here's one approach where you don't have multiple files open at the same time:
Sub test(sourceFolder As String, destinationFolder As String)
Dim dict As Object, code As String
Dim colFiles As Collection, f, k, wbNew As Workbook, wb As Workbook
Set dict = VBA.CreateObject("Scripting.Dictionary")
'ensure trailing "\"
EnsureSlash sourceFolder
EnsureSlash destinationFolder
'get a collection of all xlsx files in the source folder
Set colFiles = allFiles(sourceFolder, "*.xlsx")
If colFiles.Count = 0 Then Exit Sub 'no files
'organize the files into groups according to first four characters of the filename
For Each f In colFiles
code = Left(f.Name, 4)
If Not dict.exists(code) Then Set dict(code) = New Collection 'need new group?
dict(code).Add f 'add the file to the collection for this code
Next f
'loop over the groups
For Each k In dict
Set colFiles = dict(k) 'the files for this code
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet) 'one sheet
For Each f In colFiles
With Workbooks.Open(f.Path)
.Worksheets(1).Copy after:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = Replace(f.Name, ".xlsx", "")
.Close False
End With
Next f
Application.DisplayAlerts = False
wbNew.Sheets(1).Delete 'remove the empty sheet
Application.DisplayAlerts = True
wbNew.SaveAs destinationFolder & k & ".xlsx"
wbNew.Close
Next k
End Sub
'Return all files in `sourceFolder` which match `pattern`
' as a collection of file objects
Function allFiles(sourceFolder As String, pattern As String) As Collection
Dim col As New Collection, f
For Each f In CreateObject("scripting.filesystemobject").getfolder(sourceFolder).Files
If f.Name Like pattern Then col.Add f
Next f
Set allFiles = col
End Function
'Utility - check a path ends in a backslash
' use Application.PathSeparator if needs to be cross-platform
Sub EnsureSlash(ByRef f As String)
If Right(f, 1) <> "\" Then f = f & "\"
End Sub
I want to do the following:
Prompt user to choose a folder
Loop through folder (and subfolders if they exist)
Get all .xlsx files
Get specific column from those files (all have the same structure) and combine data from that column
I get all subfolders and all files but I get 5 times as much as I should.
L column is where I get all my data and Insert into Identical Master File (into L column).
I have 5 files - I should get 5 items in the last column, I simply add new folder in it, and same files(copied), so now I should get 10 items in the last column, instead I get 50.
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range, r As Range
Set Wb = ThisWorkbook: Wb.Sheets(2).Range("L:L").ClearContents
Dim FSO As Object, fld As Object, Fil As Object
Dim wbkCS As Workbook
Dim FolderPath As String
Dim fsoFile As Object
Dim fsoFol As Object
Dim fileName As String
Dim sWb As Workbook
Dim MatchingColumn As Range
Dim MatchingRowNb As Long
MsgBox "Choose a folder: "
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\Users\"
.AllowMultiSelect = False
If .Show <> -1 Then
MsgBox "No folder selected! Exiting script."
Exit Sub
End If
FolderPath = .SelectedItems(1)
End With
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath + "\"
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(FolderPath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(FolderPath).SubFolders
For Each fsoFile In fsoFol.Files
If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xlsx" Then
fileName = fsoFile.Name
Application.ScreenUpdating = False
MyDir = FolderPath 'fld
fileName = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While fileName <> ""
Set sWb = Workbooks.Open(fileName)
With sWb.Worksheets(2)
Rws = .Cells(Rows.Count, 12).End(xlUp).Row
Set Rng = Range(.Cells(5, 1), .Cells(Rws, 12))
End With
With Wb.Worksheets(2)
Set MatchingColumn = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
For Each r In Rng.Rows
If r.Cells(1, 1).Value2 <> vbNullString Then 'Ignoring empty rows
If r.Rows.Hidden = False Then
'We find the row where the Ids matche
MatchingRowNb = Application.Match(r.Cells(1, 1).Value2, MatchingColumn, False)
'We add the current value in the cell with the new value comming from the other file
.Cells(4 + MatchingRowNb, 12).Value2 = .Cells(4 + MatchingRowNb, 12).Value2 + r.Cells(1, 12).Value2
End If
End If
Next
End With
sWb.Close SaveChanges:=True
Application.DisplayAlerts = True
fileName = Dir()
Loop
End If
Next
Next
End If
End Sub
You're using both FSO and Dir() to loop over the files, so that's why you're getting the same files over and over.
When your sub ends up doing a bunch of things (particularly when one thing is nested in another, and so on) then it's best to consider splitting it up, so you can concentrate on the one thing that's giving you problems, without all the other things "getting in the way".
Here's a stripped-down version to show what I mean. It works but for clarity doesn't have your file processing code.
Option Explicit
Sub LoopThroughFolder()
Dim Wb As Workbook, sWb As Workbook
Dim FolderPath As String
Dim colFiles As Collection, f
'get a folder
FolderPath = ChooseFolder()
If Len(FolderPath) = 0 Then
MsgBox "No folder selected: exiting"
Exit Sub
End If
'find all excel files in subfolders of that folder
Set colFiles = FileMatches(FolderPath, "*.xlsx")
If colFiles.Count = 0 Then
MsgBox "No xlsx files found"
Exit Sub
End If
Set Wb = ThisWorkbook
Wb.Sheets(2).Range("L:L").ClearContents
'loop over the files we found
For Each f In colFiles
Set sWb = Workbooks.Open(f.Path)
'process the file here
sWb.Close SaveChanges:=True
Next f
End Sub
Function ChooseFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose a folder"
.InitialFileName = "C:\Users\"
.AllowMultiSelect = False
If .Show = -1 Then
ChooseFolder = .SelectedItems(1)
If Right(ChooseFolder, 1) <> "\" Then _
ChooseFolder = ChooseFolder + "\"
End If
End With
End Function
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function FileMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
For Each f In fldr.Files 'get files in folder
If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
Next f
If subFolders Then 'get subfolders for processing?
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
Loop
Set FileMatches = colFiles
End Function
So I'm pretty new to VBA.
The below code works fine in 2007 for listing all of the PDF files in a particular folder. However, this code doesn't seem to work when I try it in excel 2010 (it throws an error on Set fold = fso.GetFolder(folderPath))
Any Ideas What I'm doing wrong?
I do have Scripting Runtime checked. My code is below:
Sub List_files()
Dim fso As FileSystemObject
Dim fold As Folder
Dim f As File
Dim folderPath As String
Dim i As Integer
folderPath = "S:\Academic Affairs\Academic Operations Reporting\CV's"
Set fso = New FileSystemObject
Set fold = fso.GetFolder(folderPath)
i = 2
For Each f In fold.Files
If LCase(Right(f.Name, 3)) = "pdf" Then
Range("A" & i).Value = f.Name
i = i + 1
End If
Next
End Sub
I think you need a "\" on the folderPath variable... so that it is
folderPath = "S:\Academic Affairs\Academic Operations Reporting\CV's\"
If that doesn't fix it, post the error you're getting.
Here is a procedure that I use for listing files:
Function GetFileList(pDirPath As String) As Variant
On Error GoTo GetFileList_err
' Local constants / variables
Const cProcName = "GetFileList"
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim c As Double ' upper bound for file name array
Dim i As Double ' iterator for file name array
Dim vFileList() As String ' array for file names
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(pDirPath)
c = objFolder.Files.Count
i = 0
ReDim vFileList(1 To c) ' set bounds on file array now we know count
'Loop through the Files collection
For Each objFile In objFolder.Files
'Debug.Print objFile.Name
i = i + 1
vFileList(i) = objFile.Name
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
GetFileList = vFileList
GetFileList_exit:
Exit Function
GetFileList_err:
Debug.Print "Error in ", cProcName, " Err no: ", Err.Number, vbCrLf, "Err Description: ", Err.Description
Resume Next
End Function
Sub PrintFileList(pDirPath As String, _
Optional pPrintToSheet = False, _
Optional pStartCellAddr = "$A$1", _
Optional pCheckCondition = False, _
Optional pFileNameContains)
On Error GoTo PrintFileList_err
' Local constants / variables
Const cProcName = "PrintFileList"
Dim vFileList() As String ' array for file names
Dim i As Integer ' iterator for file name array
Dim j As Integer ' match counter
Dim c As String
vFileList = GetFileList(pDirPath)
c = pStartCellAddr
j = 0
For i = LBound(vFileList) To UBound(vFileList)
If pPrintToSheet Then
If pCheckCondition Then
' if pFileNameContains not in filename go to next iteration of loop
If InStr(1, vFileList(i), pFileNameContains, vbTextCompare) = 0 Then
GoTo EndLoop
End If
End If
Range(c).Offset(j, 0).Value = vFileList(i)
j = j + 1
End If
'Debug.Print vFileList(i)
i = i + 1
EndLoop:
Next
PrintFileList_exit:
Exit Sub
PrintFileList_err:
Debug.Print "Error in ", cProcName, vbCrLf, "Err no: ", Err.Number, _
vbCrLf, "Err Description: ", Err.Description
Resume Next
End Sub
The function is just for internal use, you call the procedure. Here is an example call (in this case using the userprofile windows environment variable as the path rather than a hard coded path):
call PrintFileList(environ("userprofile"), True, "$A$1", True, ".pdf")
Whenever things are not working as they "should" it's very productive to start with a minimal approach that works and build from there.
Try this that works in Excel 2016:
Option Explicit
Sub File_renaming2()
Dim objFSO As FileSystemObject
Dim mySource As Folder
Dim myFolder As File
Set objFSO = New FileSystemObject
Set mySource = objFSO.GetFolder("S:\Academic Affairs\Academic Operations Reporting\CV's\")
For Each myFolder In mySource.Files
Debug.Print myFolder.Name
Next myFolder
End Sub
Use this:
Set fso = New Scripting.FileSystemObject
Don't know how to explain:
But we need to make the full reference to the object type
CHANGE
"Dim mySource As Folder "
TO
"Dim mySource As Scripting.Folder" 'OR "Dim mySource As object"
Why ?
In my case the working code stopt from working
=> I added the "microsoft outlook object library" => it has a "Folder" type to
=> so nothing worked for me aftherwards
I need to loop through a folder containing many excel files and extract the file name and creation time to a text file. By creation time, I mean the time the file was originally created rather than the time it was created on my system.
The following code works, but gives me the wrong time. I think FileDateTime is the wrong command, but after an hour of desperate googling I haven't been able to find the correct one.
Thanks in advance for the help!
Sub CheckFileTimes()
Dim StrFile As String
Dim thisBook As String
Dim creationDate As Date
Dim outputText As String
Const ForReading = 1, ForWriting = 2
Dim fso, f
'set up output file
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("C:\TEST.txt", ForWriting, True)
'open folder and loop through
StrFile = Dir("c:\HW\*.xls*")
Do While Len(StrFile) > 0
'get creation date
creationDate = FileDateTime("C:\HW\" & StrFile)
'get filename
thisBook = StrFile
outputText = thisBook & "," & creationDate
'write to output file
f.writeLine outputText
'move to next file in folder
StrFile = Dir
Loop
f.Close
End Sub
You can use DateCreated with the FileSystemObject.
A small tweak to your current code does this
I have tided up the the variables as well
Sub CheckFileTimes()
Dim StrFile As String
Dim StrCDate As Date
Dim fso As Object
Dim f As Object
'set up output file
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpentextFile("C:\TEST.txt", 2, True)
'open folder and loop through
StrFile = Dir("c:\HW\*.xls*")
Do While Len(StrFile) > 0
Set objFile = fso.getfile("c:\HW\" & StrFile)
'get creation date
StrCDate = objFile.datecreated
'write to output file
f.writeLine StrFile & "," & StrCDate
'move to next file in folder
StrFile = Dir
Loop
f.Close
End Sub
Welp, I found the answer. Looks like I wasn't too far off (though I don't think this is anywhere near optimal). Thanks to everyone who took a look at this.
Sub CheckFileTimes3()
Dim StrFile, thisBook, outputText As String
Dim creationDate As Date
Dim fso, f
Dim oFS As Object
Const ForReading = 1, ForWriting = 2
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'open txt file for storing results
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("C:\TEST.txt", ForWriting, True)
'loop through all files in given folder
StrFile = Dir("c:\HW\*.xls*")
Do While Len(StrFile) > 0
Workbooks.Open Filename:="C:\HW\" & StrFile
creationDate = ActiveWorkbook.BuiltinDocumentProperties("Creation Date")
thisBook = StrFile
outputText = thisBook & "," & creationDate
'MsgBox outputText
f.writeLine outputText
ActiveWorkbook.Close
StrFile = Dir
Loop
f.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub