VBA to List items (including folders) with specific word

darkhangelsk

New Member
Joined
Feb 10, 2013
Messages
20
Hello,

I would like to ask if there's a way for VBA to list all files (including folders) with word OLDIES_(whatever the text or number here)

Similar to this but with additional column to put location and extension.

VBA Code:
Sub Example4()

Dim varDirectory As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String

strDirectory = "C:\Desktop"
i = 1
flag = True
varDirectory = Dir(strDirectory, vbDirectory)

While flag = True
    If varDirectory = "" Then
        flag = False
    Else
        Cells(i + 1, 1) = varDirectory
        Cells(i + 1, 2) = strDirectory + varDirectory
        'returns the next file or directory in the path
        varDirectory = Dir
        i = i + 1
    End If

Wend
End Sub

Column will be like this (comma will be next tab):

Name, Location, extension (if folder then just folder)
OLDIES_12345, C:Desktop, Folder
OLDER_23456, C:Desktop, .zip
OLDER_23457, C:Desktop, .xls

Thank you!
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
3,090
Hi darkhangelsk. You can trial this. HTH. Dave
Code:
Sub ListOLDIES()
Dim FSO As Object, FSOSubFolder As Object, FileName As String
Dim FSOFile As Object, objFolder As Object, RowNum As Integer
Dim ExtSplit As Variant, NameSplit As Variant
strDirectory = "C:\Desktop\"
RowNum = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strDirectory)
For Each FSOSubFolder In objFolder.subfolders
    ListOLDIES
Next FSOSubFolder

For Each FSOFile In objFolder.Files
If InStr(FSOFile.path, "OLDIES") Then
ExtSplit = Split(FSOFile.path, ".")
NameSplit = Split(FSOFile.path, "\")
FileName = Left(NameSplit(UBound(NameSplit)), _
           Len(NameSplit(UBound(NameSplit))) - Len(ExtSplit(UBound(ExtSplit))) - 1)
Flpath = Left(FSOFile.path, Len(FSOFile.path) - Len(NameSplit(UBound(NameSplit))))
ActiveSheet.Cells(RowNum, 1) = FileName & ", " & Flpath & ", ." & ExtSplit(UBound(ExtSplit))
RowNum = RowNum + 1
End If
Next FSOFile
Set objFolder = Nothing
Set FSO = Nothing
End Sub
 

darkhangelsk

New Member
Joined
Feb 10, 2013
Messages
20
Hi darkhangelsk. You can trial this. HTH. Dave
Code:
Sub ListOLDIES()
Dim FSO As Object, FSOSubFolder As Object, FileName As String
Dim FSOFile As Object, objFolder As Object, RowNum As Integer
Dim ExtSplit As Variant, NameSplit As Variant
strDirectory = "C:\Desktop\"
RowNum = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strDirectory)
For Each FSOSubFolder In objFolder.subfolders
    ListOLDIES
Next FSOSubFolder

For Each FSOFile In objFolder.Files
If InStr(FSOFile.path, "OLDIES") Then
ExtSplit = Split(FSOFile.path, ".")
NameSplit = Split(FSOFile.path, "\")
FileName = Left(NameSplit(UBound(NameSplit)), _
           Len(NameSplit(UBound(NameSplit))) - Len(ExtSplit(UBound(ExtSplit))) - 1)
Flpath = Left(FSOFile.path, Len(FSOFile.path) - Len(NameSplit(UBound(NameSplit))))
ActiveSheet.Cells(RowNum, 1) = FileName & ", " & Flpath & ", ." & ExtSplit(UBound(ExtSplit))
RowNum = RowNum + 1
End If
Next FSOFile
Set objFolder = Nothing
Set FSO = Nothing
End Sub
Thanks for replying. I tried this but i got an error of "Out of stack space". I was also thinking if this will work with subfolders. Again, thank you, will try to research how to remove the error as well.
 

NdNoviceHlp

Well-known Member
Joined
Nov 9, 2002
Messages
3,090
Whoops! My bad. It did work with my limited testing however I can generate the same error... it's due to the recursive subfolder search. If you take the subfolder search out then all is well. I can't seem to get the subfolder part to work? Maybe others can help if it's needed for your outcome. Dave
Code:
Sub ListOLDIES()
Dim FSO As Object, FSOSubFolder As Object, FileName As String
Dim FSOFile As Object, objFolder As Object, RowNum As Integer
Dim strDirectory As String, ExtSplit As Variant, NameSplit As Variant
strDirectory = "C:\Desktop\"
RowNum = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strDirectory)
above:
For Each FSOFile In objFolder.Files
If InStr(FSOFile.path, "OLDIES") Then
ExtSplit = Split(FSOFile.path, ".")
NameSplit = Split(FSOFile.path, "\")
FileName = Left(NameSplit(UBound(NameSplit)), _
           Len(NameSplit(UBound(NameSplit))) - Len(ExtSplit(UBound(ExtSplit))) - 1)
Flpath = Left(FSOFile.path, Len(FSOFile.path) - Len(NameSplit(UBound(NameSplit))))
ActiveSheet.Cells(RowNum, 1) = FileName & ", " & Flpath & ", ." & ExtSplit(UBound(ExtSplit))
RowNum = RowNum + 1
End If
Next FSOFile
Set objFolder = Nothing
Set FSO = Nothing
End Sub
 
Solution

Forum statistics

Threads
1,176,634
Messages
5,904,156
Members
435,074
Latest member
McKay_S

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top