Scribd
Upload
100 views9 pages

Program To List Folders

This document contains VBA code to recursively search folders and subfolders to list all files. It uses a dictionary object to store the folder paths and file names. The files are then listed on a worksheet with the file name, path, and size. A custom function is also included to extract just the file name from a full file path.

Uploaded by

Anjana Nair
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as ODT, PDF, TXT or read online on Scribd
100 views9 pages

Program To List Folders

This document contains VBA code to recursively search folders and subfolders to list all files. It uses a dictionary object to store the folder paths and file names. The files are then listed on a worksheet with the file name, path, and size. A custom function is also included to extract just the file name from a full file path.

Uploaded by

Anjana Nair
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as ODT, PDF, TXT or read online on Scribd

Program to list folders

Sub FolderNames()
'Update 20141027
[Link] = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With [Link](msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
End With
On Error Resume Next
xPath = [Link](msoFileDialogFolderPicker).SelectedItems(1)
& "\"
[Link]
Set xWs = [Link]
[Link](1, 1).Value = xPath
[Link](2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date
Created", "Date Last Modified")
Set fso = CreateObject("[Link]")
Set folder1 = [Link](xPath)
getSubFolder folder1
[Link](2, 1).Resize(1, 5).[Link] = 65535
[Link](2, 1).Resize(1, 5).[Link]
[Link] = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In [Link]
    xRow = Range("A1").End(xlDown).Row + 1
    Cells(xRow, 1).Resize(1, 5).Value = Array([Link],
Left([Link], InStrRev([Link], "\")), [Link],
[Link], [Link])
Next SubFolder
For Each subfld In [Link]
    getSubFolder subfld
Next subfld
End Sub
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

Sub MainList()
'Updateby20150706
Set folder = [Link](msoFileDialogFolderPicker)
If [Link] <> -1 Then Exit Sub
xDir = [Link](1)
Call ListFilesInFolder(xDir, True)
End Sub
Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As
Boolean)
Dim xFileSystemObject As Object
Dim xFolder As Object
Dim xSubFolder As Object
Dim xFile As Object
Dim rowIndex As Long
Set xFileSystemObject = CreateObject("[Link]")
Set xFolder = [Link](xFolderName)
rowIndex = [Link]("A65536").End(xlUp).Row + 1
For Each xFile In [Link]
  [Link](rowIndex, 1).Formula = [Link]
  rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
  For Each xSubFolder In [Link]
    ListFilesInFolder [Link], True
  Next xSubFolder
End If
Set xFile = Nothing
Set xFolder = Nothing
Set xFileSystemObject = Nothing
End Sub
Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
Dim xFolder As Object
Dim xFolderItem As Object
Dim xShell As Object
xName = StrConv(xName, vbUnicode)
xPath = StrConv(xPath, vbUnicode)
Set xShell = CreateObject("[Link]")
Set xFolder = [Link](StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
  Set xFolderItem = [Link](StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
  GetFileOwner = [Link](xFolderItem, 8)
Else
  GetFileOwner = ""
End If
Set xShell = Nothing
Set xFolder = Nothing
Set xFolderItem = Nothing
End Function

$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

Sub ListAllFilesInAllFolders()
 
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, F As Boolean
    Dim objShell As Object, objFolder As Object, AllFolders As Object,
AllFiles As Object
    Dim MySheet As Worksheet
     
    On Error Resume Next
     
    '************************
    'Select folder
    Set objShell = CreateObject("[Link]")
    Set objFolder = [Link](0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = [Link] & "\"
    Else
        Exit Sub
       'MyPath = "G:\BackUp\"
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
     
    '************************
    'List all folders
     
    Set AllFolders = CreateObject("[Link]")
    Set AllFiles = CreateObject("[Link]")
    [Link] (MyPath), ""
    i = 0
    Do While i < [Link]
        Key = [Link]
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) =
vbDirectory Then
                    [Link] (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
     
    'List all files
    For Each Key In [Link]
        MyFileName = Dir(Key & "*.*")
        'MyFileName = Dir(Key & "*.PDF")    'only PDF files
        Do While MyFileName <> ""
            [Link] (Key & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
     
    '************************
    'List all files in Files sheet
     
    For Each MySheet In [Link]
        If [Link] = "Files" Then
            Sheets("Files").[Link]
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then [Link] = "Files"
 
    'Sheets("Files").[A1].Resize([Link], 1) =
[Link]([Link])
    Sheets("Files").[A1].Resize([Link], 1) =
[Link]([Link])
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

Split file
For using defined custom function, go to cell C14 and enter the function
=FileOrFolderName(B14,FALSE) and in cell D14, enter the function
=FileOrFolderName(B14,TRUE), where cell B14 contain the file path.
2222
Sub ListAllFilesInAllFolders()

Dim MyPath As String, MyFolderName As String, MyFileName As String


Dim i As Integer, F As Boolean
Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As
Object
Dim MySheet As Worksheet

On Error Resume Next

'************************
'Select folder
Set objShell = CreateObject("[Link]")
Set objFolder = [Link](0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
MyPath = [Link] & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing

'************************
'List all folders

Set AllFolders = CreateObject("[Link]")


Set AllFiles = CreateObject("[Link]")
[Link] (MyPath), ""
i=0
Do While i < [Link]
Key = [Link]
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
[Link] (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i=i+1
Loop

'List all files


For Each Key In [Link]
MyFileName = Dir(Key & "*.*")
'MyFileName = Dir(Key & "*.PDF") 'only PDF files
Do While MyFileName <> ""
[Link] (Key & MyFileName), ""
MyFileName = Dir
Loop
Next

'************************
'List all files in Files sheet

For Each MySheet In [Link]


If [Link] = "Files" Then
Sheets("Files").[Link]
F = True
Exit For
Else
F = False
End If
Next
If Not F Then [Link] = "Files"

'Sheets("Files").[A1].Resize([Link], 1) =
[Link]([Link])
Sheets("Files").[A1].Resize([Link], 1) =
[Link]([Link])
Set AllFolders = Nothing
Set AllFiles = Nothing
End Sub
Function FunctionGetFileName(FullPath As String) As String
'Update 20140210
Dim splitList As Variant
splitList = [Link](FullPath, "\")
FunctionGetFileName = splitList(UBound(splitList, 1))
End Function

Program to find and list duplicate folders


Sub FindDuplicateFiles()
Dim pth1 As String
Dim arrd() As Variant
Dim arru() As Variant
ReDim arrd(0 To 2, 0)
ReDim arru(0 To 2, 0)
 
With [Link](msoFileDialogFolderPicker)
.Show
pth1 = .SelectedItems(1) & "\"
End With
 
[Link]
Set x = ActiveSheet
 
[Link] = False
[Link]("A1") = "Duplicate files"
[Link]("A2") = "Path"
[Link]("B2") = "File name"
[Link]("C2") = "Size"
[Link]("A:F").[Link] = False
[Link]("A1:C2").[Link] = True
 
Recursive pth1
 
Lrow = [Link]("A" & [Link]).End(xlUp).Row
[Link]("A2:C" & Lrow).Sort Key1:=[Link]("B1"), Header:=xlYes
 
arr1 = [Link]("A3:C" & Lrow).Value
 
[Link]("A3:C" & Lrow).Clear
 
For r1 = LBound(arr1, 1) + 1 To UBound(arr1, 1)
 
    If arr1(r1, 2) = arr1(r1 - 1, 2) Then
     
        arrd(0, UBound(arrd, 2)) = arr1(r1 - 1, 1)
        arrd(1, UBound(arrd, 2)) = arr1(r1 - 1, 2)
        arrd(2, UBound(arrd, 2)) = arr1(r1 - 1, 3)
         
        ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
         
        arr1(r1 - 1, 1) = ""
        arr1(r1 - 1, 2) = ""
        arr1(r1 - 1, 3) = ""
         
        chk = True
     
    Else
     
        If chk = True Then
         
            arrd(0, UBound(arrd, 2)) = arr1(r1 - 1, 1)
            arrd(1, UBound(arrd, 2)) = arr1(r1 - 1, 2)
            arrd(2, UBound(arrd, 2)) = arr1(r1 - 1, 3)
            chk = False
             
            ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
             
            arr1(r1 - 1, 1) = ""
            arr1(r1 - 1, 2) = ""
            arr1(r1 - 1, 3) = ""
         
        Else
         
            arru(0, UBound(arru, 2)) = arr1(r1 - 1, 1)
            arru(1, UBound(arru, 2)) = arr1(r1 - 1, 2)
            arru(2, UBound(arru, 2)) = arr1(r1 - 1, 3)
             
            ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
             
            arr1(r1 - 1, 1) = ""
            arr1(r1 - 1, 2) = ""
            arr1(r1 - 1, 3) = ""
         
        End If
     
    End If
 
Next r1
 
If chk = True Then
    arrd(0, UBound(arrd, 2)) = arr1(r1 - 1, 1)
    arrd(1, UBound(arrd, 2)) = arr1(r1 - 1, 2)
    arrd(2, UBound(arrd, 2)) = arr1(r1 - 1, 3)
Else
    arru(0, UBound(arru, 2)) = arr1(r1 - 1, 1)
    arru(1, UBound(arru, 2)) = arr1(r1 - 1, 2)
    arru(2, UBound(arru, 2)) = arr1(r1 - 1, 3)
End If
 
[Link]("A3").Resize(UBound(arrd, 2) + 1, UBound(arrd, 1) + 1) = [Link](a
 
[Link]("A" & UBound(arrd, 2) + 3) = "Unique files"
[Link]("A" & UBound(arrd, 2) + 4) = "Path"
[Link]("B" & UBound(arrd, 2) + 4) = "File name"
[Link]("C" & UBound(arrd, 2) + 4) = "Size"
[Link]("A" & UBound(arrd, 2) + 3 & ":C" & UBound(arrd, 2) + 4).[Link] = True
[Link]("A" & UBound(arrd, 2) + 5).Resize(UBound(arru, 2) + 1, UBound(arru, 1) + 1) =
[Link](arru)
 
[Link]("A:C").AutoFit
 
End Sub
 
Sub Recursive(FolderPath As String)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
            Folders(UBound(Folders)) = Value
            ReDim Preserve Folders(UBound(Folders) + 1)
        Else
            Lrow = [Link]("A" & [Link]).End(xlUp).Row + 1
            [Link]("A" & Lrow) = FolderPath
            [Link]("B" & Lrow) = Value
            [Link]("C" & Lrow) = FileLen(FolderPath & Value)
        End If
    End If
    Value = Dir
Loop
For Each Folder In Folders
    Recursive FolderPath & Folder & "\"
Next Folder
End Sub

You might also like