BIGTONE559
Active Member
- Joined
- Apr 20, 2011
- Messages
- 336
I need help looping through folders/sub folders and counting file types ".xlsx".
Please help!
Please help!
Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
On Error GoTo Err_Handler
' Variation of http://allenbrowne.com/ser-59.html
Dim colDirList As New Collection
Dim varItem As Variant
Dim FileList() As Variant
Dim FileCnt As Long
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
If lst Is Nothing Then
FileCnt = 0
For Each varItem In colDirList
ReDim Preserve FileList(FileCnt)
FileList(FileCnt) = varItem
FileCnt = FileCnt + 1
Next
Else
For Each varItem In colDirList
lst.AddItem varItem
Next
End If
ListFiles = FileList
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & err.Number & ": " & err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
dim myfiles as variant
'FolderName is the folder you want to search through.
'FileType can be *.*, *.xls, *.xls?, what ever you're looking for.
'True is a boolean true/false to include sub directories.
MyFiles = ListFiles(FolderName, FileType, True)
Sub ListFiles()
' Lists files of user-selected type, located in user-selected folder
Dim sFileType$, sPath$, sMsg$, lNextRow&
Dim fDlg, fType, f, bReturn As Boolean
'Get the folder
If Application.VERSION > 9 Then
Set fDlg = Application.FileDialog(4)
With fDlg
If .Show = False Then Exit Sub 'User cancelled
sPath = .SelectedItems(1)
End With
Else
sPath = GetDirectory(mszPickFolder)
End If
If sPath = "" Then Exit Sub 'User cancelled
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
'Instructional info for user filetype input
sMsg = "Enter the file type extension." & vbCrLf
sMsg = sMsg & "Example: xls" & vbCrLf
sMsg = sMsg & "(Not case sensitive)" & vbCrLf & vbCrLf
sMsg = sMsg & "Separate types with a comma. (no spaces) ie. xls,pdf,txt,etc " & vbCrLf & vbCrLf
sMsg = sMsg & "For types having no extension, enter a minus (-) sign."
'Prompt for user input
sFileType = InputBox(sMsg)
If sFileType = "" Then Beep: Exit Sub 'If user cancels
lNextRow = InputBox("What row do you want to start in?")
Application.ScreenUpdating = False
On Error GoTo Cleanup
f = Dir(sPath, 7)
Do While f <> ""
'Filter for filetype
For Each fType In Split(sFileType, ",", , vbTextCompare)
Cells(lNextRow, 1) = f: Application.StatusBar = "Processing File: " & f
lNextRow = lNextRow + 1
Next fType
f = Dir 'Get next file
Loop 'While f <> ""
Cleanup:
With Application
.StatusBar = False: .ScreenUpdating = True
End With
End Sub 'ListFiles