Find Windows subfolders with specified name - vba

I want to loop through a folder (G:/Proj) and find any subfolders named "SUMMARY LOG" and then print the Excel files, usually just one, within each of those folders.
This is the main folder (Proj) with all of the project folders within it
This is a screenshot of just one of the files I want to print out.
Each project has a SUMMARY LOG folder.
Here is the VBA code. It loops through every sub folder and prints out every Excel file in those folders not just the "SUMMARY LOG".
Sub LoopFolders()
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim wbk As Workbook
' Parent folder including trailing backslash
strFolder = "G:/Proj/"
' Loop through the subfolders and fill Collection object
strSubFolder = Dir(strFolder & "*", vbDirectory)
Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through Excel workbooks in subfolder
strFile = Dir(strFolder & varItem & "\*.xls*")
Do While strFile <> ""
' Open workbook
Set wbk = Workbooks.Open(Filename:=strFolder & _
varItem & "\" & strFile, AddToMRU:=False)
' Do something with the workbook
ActiveSheet.PrintOut
' Close it
wbk.Close SaveChanges:=False
strFile = Dir
Loop
Next varItem
End Sub

This is how I changed your code (please note that you should set your "objects" to nothing at the end of your code).
Note that I just used a simple "If" statement with the "InStr" function to try and catch the buzzwords associated with your excel workbooks. Here is what my simulated folder looked like:
Simulated Folder with File Names
Sub LoopFolders()
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim wbk As Workbook
' Parent folder including trailing backslash
strFolder = "C:\Users\anm2mip\Desktop\Exp\"
' Loop through the subfolders and fill Collection object
strSubFolder = Dir(strFolder & "*", vbDirectory)
Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through Excel workbooks in subfolder
strFile = Dir(strFolder & varItem & "\*.xls*") 'never mind the .xlsx, I forgot that the * symbol is wildcard.
Do While strFile <> ""
If InStr(strFile, "Summary") And InStr(strFile, "Log") Then
' Open workbook
Set wbk = Workbooks.Open(FileName:=strFolder & _
varItem & "\" & strFile, AddToMRU:=False)
' Do something with the workbook
MsgBox strFile
' ActiveSheet.PrintOut
' Close it
wbk.Close SaveChanges:=False
End If
strFile = Dir
Loop
Next varItem
Set colSubFolders = Nothing
Set varItem = Nothing
Set wbk = Nothing
End Sub
UPDATE
Test Folder Structure
Note that I threw a couple different excel file types and a word document in there as well, and my code below filters out all except the excel file types that I've specified.
I used this answer as a reference: Recursive drill down into folders example. Thank you user #Cor_Blimey for the easy-to-use post.
Sub LoopFolders()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Dim colFiles As New Collection
Dim wbk As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("C:\Users\anm2mip\Desktop\Exp\")
' Parent folder including trailing backslash
'strFolder = "C:\Users\anm2mip\Desktop\Exp\"
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 'dequeue
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder
Next oSubfolder
'Filter subfolders here
If InStr(oFolder.Name, "Summary") And InStr(oFolder.Name, "Log") Then
For Each oFile In oFolder.Files
'You can filter files here with an if...then statement
If oFile.Type = "Microsoft Excel Worksheet" Or _
oFile.Type = "Microsoft Excel 97-2003 Worksheet" Or _
oFile.Type = "Microsoft Excel Macro-Enabled Worksheet" Then
colFiles.Add Item:=oFile, Key:=oFile.Name
Next oFile
End If
Loop
MsgBox "Number of files held in Summary Log folders is: " & colFiles.Count
For Each oFile In colFiles
Set wbk = Workbooks.Open(FileName:=oFile.Path, AddtoMRU:=False)
MsgBox oFile.Name
'Do your printing operation here.
wbk.Close SaveChanges:=False
Next oFile
Set fso = Nothing
Set oFolder = Nothing
Set oSubfolder = Nothing
Set oFile = Nothing
Set queue = Nothing
Set wbk = Nothing
End Sub

Related

How to make this code apply recursively to all sub-folders

I found this code to change .doc files to .docx files. I would like to modify it so I can specify a top level folder and have it work through it AND every sub-folder. Appreciate any assistance.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "C:\Temp\doc\"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
I suggest switching from Dir to FileSystemObject. With FSO, you can get a folder as an object with GetFolder and then access the Folder Object's files and folders as collections. This enables For Each loops like For Each File In Folder. and then you can do the recursion For Each SubFolder In Folder where you can re-call the macro as if each subfolder was the top level folder.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim strFolder As String
strFolder = "C:\Temp\doc\"
Dim StartingFolder As Object
Set StartingFolder = CreateObject("Scripting.FileSystemObject").GetFolder(strFolder)
FolderToDocx StartingFolder, objWordApplication
Set objWordApplication = Nothing
End Sub
Sub FolderToDocx(Folder As Object, wdApp As Word.Application)
Dim File As Object
For Each File In Folder.Files
If LCase(Split(File.Name, ".")(1)) = "doc" Then SaveToDocx File, wdApp
Next
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
FolderToDocx SubFolder, wdApp
Next
End Sub
Sub SaveToDocx(File As Object, wdApp As Word.Application)
With wdApp.Documents.Open(File.Path, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
.SaveAs Filename:=File.Path & "x"), FileFormat:=16
.Close
End With
End Sub
The file matching expression I did in this answer is just an example. You may want to improve that expression to prevent errors. One error that may come up is with Microsoft Office temp files. They are usually hidden and prefixed with ~$ like ~$Word Document.docx. So to avoid accidentally matching one of those, it would be good to exclude anything with that prefix.
I would recommend splitting out the file searching into a separate function: it's easier to tweak your logic and the main method doesn't get overloaded by the code for finding the files.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim colFiles As Collection
Dim strFile
Set colFiles = GetMatchingFiles("C:\Temp\doc\", "*.doc")
For Each strFile In colFiles
With objWordApplication
Set objWordDocument = .Documents.Open(Filename:=strFile, _
AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs Filename:=strFile & "x", FileFormat:=16
.Close
End With
End With
Next strFile
End Sub
'Search beginning at supplied folder root, including subfolders, for
' files matching the supplied pattern. Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
Dim colFolders As New Collection, colFiles As New Collection
Dim fso As Object, fldr, subfldr, fl
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add startPath 'queue up root folder for processing
Do While colFolders.Count > 0 'loop until the queue is empty
fldr = colFolders(1) 'get next folder from queue
colFolders.Remove 1 'remove current folder from queue
With fso.getfolder(fldr)
For Each fl In .Files
If UCase(fl.Name) Like UCase(filePattern) Then 'check pattern
colFiles.Add fl.Path 'collect the full path
End If
Next fl
For Each subfldr In .subFolders
colFolders.Add subfldr.Path 'queue any subfolders
Next subfldr
End With
Loop
Set GetMatchingFiles = colFiles
End Function

Word will no longer open through excel VBA

Set up a macro to open word documents through excel. It's been working fine, but after copying the code from the test environment into another file it's refusing to open word on every machine I test it on. Every other part of the macro is working fine, but for some reason word will no longer open via macro.
I've attached the code, but any help would be appreciated. It was working earlier today, and because of this i'm having trouble identifying the problem.
Public Function Method2(ByVal rngl As Range, ByVal strSearch As Variant, ByVal sPath As String)
Dim filePath As String
Dim directory As String
Dim fileName As String
Dim myPath As String
Dim myFile As File
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myExtension As String
Dim mySubFolder As Folder
Dim mySubFolder2 As Folder
Dim objWord
Dim objDoc
Dim rngRange
Dim rng1 As Range
Set myFolder = FSO.GetFolder(sPath)
directory = "S:\File Recipes\"
fileName = "Yaroze_Test"
myExtension = "*.docx*"
Set rng1 = Range("A:A").find(strSearch, , xlValues, xlWhole)
If strSearch = "" Then
MsgBox "Please Enter a Product Code!"
Exit Function
End If
If Not rng1 Is Nothing Then
MsgBox "Product Codes Found!"
For Each mySubFolder In myFolder.SubFolders
For Each mySubFolder2 In mySubFolder.SubFolders
For Each myFile In mySubFolder.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
For Each myFile In mySubFolder2.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
' MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
' MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
Next
Next
Else
MsgBox "Product Codes Not Found!"
End If
' Set rngRange = _
objWord.Range(objWord.Paragraphs(1).Start, objWord.Paragraphs(1).End - 1)
' rngRange.InsertAfter _
"This is now the last sentence in paragraph one."
I've attempted to test the Macro on other computers to see if it was just the copy of word I was using, and I've tested writing new Macros to open word. They worked initially but other macros are now no longer working. I've tried disabling office from references in VBA and testing with that, and I've made sure it's not an issue with instances of word being left open.

Need to modify my VBA code to include subfolders as well

I have created a VBA code that loops through all excel workbooks in a given folder , opens then, refreshes the sheet, pauses for 10 seconds, closes and saves and moves on to the next. The issue I am facing is that it wont do it for the excel workbooks in the subfolder, Please can someone assist.
The code is as per below:
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
Application.Calculate
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:10"))
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Its probably an old question indeed, but still, I enjoyed writing it somehow. And in my solution, you get some nice printing in the console. Here you go:
Option Explicit
Function GetFiles(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFiles = New Collection
strFile = Dir(Folder & "\*")
Do While strFile <> ""
GetFiles.Add strFile
strFile = Dir
Loop
End Function
Function GetFolders(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFolders = New Collection
strFile = Dir(Folder & "\*", vbDirectory)
Do While strFile <> ""
If GetAttr(Folder & "\" & strFile) And vbDirectory Then GetFolders.Add strFile
strFile = Dir
Loop
End Function
Sub LoopThroughSubfoldersAsWell()
Dim colFoFi As Collection
Dim varEl01 As Variant
Dim varEl02 As Variant
Dim varEl03 As Variant
Dim strLine As String: strLine = "--------------------------"
Dim strAddress As String: strAddress = "C:\Users\UserName\Desktop\Testing01\"
Debug.Print strAddress
Set colFoFi = GetFiles(strAddress)
For Each varEl01 In colFoFi
Debug.Print varEl01
Next varEl01
Debug.Print strLine
Set colFoFi = GetFolders(strAddress)
For Each varEl01 In colFoFi
If Len(varEl01) > 2 Then 'to avoid some hidden stuff
Set varEl02 = GetFiles(strAddress & varEl01)
Debug.Print (strAddress & varEl01)
For Each varEl03 In varEl02
Debug.Print varEl03
Next varEl03
Debug.Print strLine
End If
Next varEl01
End Sub

Looping through all files in a folder

I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore

script to find number of rows in excel under a particular folder using vb

I need to find out the number of rows in each excel sheets under a folder .Google search shows that the below script works..but having very less knowledge on vb ,i could not resolve it.The script containe ''Wscript object.I think this works with out this object as well
The thing is under "c:\temp", i have 100 excel sheets(.xls). Need to find out number of rows in each file. Help needed from vb experts
Dim objFSO, strFolder, objFolder, objFile, objExcel, objSheet, objRange, objRows As Object
Dim strExtension As String
Dim V_FilePath As String = " "
' Specify folder.
strFolder = "c:\\temp" -----
objExcel = CreateObject("Excel.Application")
' Enumerate files in the folder.
objFSO = CreateObject("Scripting.FileSystemObject")
objFolder = objFSO.GetFolder(strFolder)
For Each objFile In objFolder.Files
' Select only Excel spreadsheet file.
strExtension = objFSO.GetExtensionName(objFile.Path)
If (strExtension = "xls") Or (strExtension = "xlsx") Then
' Open each spreadsheet and count the number of rows.
objExcel.Workbooks.Open(objFile.Path)
objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objRange = objSheet.UsedRange
objRows = objRange.Rows
' Display spreadsheet name and the number of rows.
MsgBox(objExcel.ActiveWorkbook + CStr(objRows.Count))
''Wscript.Echo(objFile.Path & " (" & objRows.Count & ")")
' Close the spreadsheet.
objExcel.ActiveWorkbook.Close()
End If
Next
' Clean up.
objExcel.Application.Quit()
Dts.TaskResult = ScriptResults.Success
End Sub
Make sure you're declaring the sub routine at the top with "Sub _()". Also, there are a few things that I believe are syntactically incorrect about this one. Try this instead:
Sub blah()
Dim objFSO, strFolder, objFolder, objFile, objExcel, objSheet, objRange, objRows As Object
Dim strExtension As String
Dim V_FilePath As String
V_FilePath = " "
' Specify folder.
strFolder = "c:\\temp"
objExcel = CreateObject("Excel.Application")
' Enumerate files in the folder.
objFSO = CreateObject("Scripting.FileSystemObject")
objFolder = objFSO.GetFolder(strFolder)
For Each objFile In objFolder.Files
' Select only Excel spreadsheet file.
strExtension = objFSO.GetExtensionName(objFile.Path)
If (strExtension = "xls") Or (strExtension = "xlsx") Then
' Open each spreadsheet and count the number of rows.
objExcel.Workbooks.Open (objFile.Path)
objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objRange = objSheet.UsedRange
objRows = objRange.Rows
' Display spreadsheet name and the number of rows.
MsgBox (objExcel.ActiveWorkbook + CStr(objRows.Count))
''Wscript.Echo(objFile.Path & " (" & objRows.Count & ")")
' Close the spreadsheet.
objExcel.ActiveWorkbook.Close
End If
Next
' Clean up.
objExcel.Application.Quit
Dts.TaskResult = ScriptResults.Success
End Sub
If you're doing this in VBA in an Excel Macro, perhaps this will work a bit better:
Sub LoopThroughFiles()
Dim strFile As String
Dim strPath As String
Dim colFiles As New Collection
Dim i As Integer
Dim rowCount As Integer
strPath = "C:\Users\[windows_username]\Documents\" 'Your path here
strFile = Dir(strPath)
While strFile <> ""
colFiles.Add strFile
strFile = Dir
Wend
'List filenames in Column A of the active sheet
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
ActiveSheet.Cells(i, 1).Value = colFiles(i)
Workbooks.Open strPath & colFiles(i)
rowCount = ActiveSheet.UsedRange.Rows.Count
Workbooks(colFiles(i)).Close
'Workbooks.Close
'ThisWorkbook.Close
ActiveSheet.Cells(i, 2).Value = rowCount
Next i
End If
End Sub
This would work
MsgBox(objFile.name + CStr(objRows.Count))