Program to list folders

Sub FolderNames()
'Update 20141027
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
& "\"
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date
Created", "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = 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 prntfld.SubFolders
    xRow = Range("A1").End(xlDown).Row + 1
    Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path,
Left(SubFolder.Path, InStrRev(SubFolder.Path, "\")), SubFolder.Name,
SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
    getSubFolder subfld
Next subfld
End Sub
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

Sub MainList()
'Updateby20150706
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(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("Scripting.FileSystemObject")
Set xFolder = xFileSystemObject.GetFolder(xFolderName)
rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
For Each xFile In xFolder.Files
  Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Name
  rowIndex = rowIndex + 1
Next xFile
If xIsSubfolders Then
  For Each xSubFolder In xFolder.SubFolders
    ListFilesInFolder xSubFolder.Path, 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("Shell.Application")
Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
If Not xFolder Is Nothing Then
  Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
End If
If Not xFolderItem Is Nothing Then
  GetFileOwner = xFolder.GetDetailsOf(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("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & "\"
    Else
        Exit Sub
       'MyPath = "G:\BackUp\"
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
     
    '************************
    'List all folders
     
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) =
vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
     
    'List all files
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.*")
        'MyFileName = Dir(Key & "*.PDF")    'only PDF files
        Do While MyFileName <> ""
            AllFiles.Add (Key & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
     
    '************************
    'List all files in Files sheet
     
    For Each MySheet In ThisWorkbook.Worksheets
        If MySheet.Name = "Files" Then
            Sheets("Files").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then Sheets.Add.Name = "Files"
 
    'Sheets("Files").[A1].Resize(AllFolders.Count, 1) =
WorksheetFunction.Transpose(AllFolders.keys)
    Sheets("Files").[A1].Resize(AllFiles.Count, 1) =
WorksheetFunction.Transpose(AllFiles.keys)
    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("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
If Not objFolder Is Nothing Then
'MyPath = "\\infra\Services\turb"
 MyPath = objFolder.self.Path & "\"
Else
Exit Sub
'MyPath = "\\infra\Services\turb"
End If
Set objFolder = Nothing
Set objShell = Nothing

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

Set AllFolders = CreateObject("Scripting.Dictionary")

Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i=0
Do While i < AllFolders.Count
Key = AllFolders.keys
MyFolderName = Dir(Key(i), vbDirectory)
Do While MyFolderName <> ""
If MyFolderName <> "." And MyFolderName <> ".." Then
If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
AllFolders.Add (Key(i) & MyFolderName & "\"), ""
End If
End If
MyFolderName = Dir
Loop
i=i+1
Loop

'List all files

For Each Key In AllFolders.keys
 MyFileName = Dir(Key & "*.*")
'MyFileName = Dir(Key & "*.PDF") 'only PDF files
Do While MyFileName <> ""
AllFiles.Add (Key & MyFileName), ""
MyFileName = Dir
Loop
Next

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

For Each MySheet In ThisWorkbook.Worksheets

If MySheet.Name = "Files" Then
Sheets("Files").Cells.Delete
F = True
Exit For
Else
F = False
End If
Next
If Not F Then Sheets.Add.Name = "Files"

'Sheets("Files").[A1].Resize(AllFolders.Count, 1) =
WorksheetFunction.Transpose(AllFolders.keys)
Sheets("Files").[A1].Resize(AllFiles.Count, 1) =
WorksheetFunction.Transpose(AllFiles.keys)
Set AllFolders = Nothing
Set AllFiles = Nothing
End Sub
Function FunctionGetFileName(FullPath As String) As String
'Update 20140210
Dim splitList As Variant
splitList = VBA.Split(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 Application.FileDialog(msoFileDialogFolderPicker)
.Show
pth1 = .SelectedItems(1) & "\"
End With
 
Sheets.Add
Set x = ActiveSheet
 
Application.ScreenUpdating = False
x.Range("A1") = "Duplicate files"
x.Range("A2") = "Path"
x.Range("B2") = "File name"
x.Range("C2") = "Size"
x.Range("A:F").Font.Bold = False
x.Range("A1:C2").Font.Bold = True
 
Recursive pth1
 
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
 
arr1 = x.Range("A3:C" & Lrow).Value
 
x.Range("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
 
x.Range("A3").Resize(UBound(arrd, 2) + 1, UBound(arrd, 1) + 1) = Application.Transpose(a
 
x.Range("A" & UBound(arrd, 2) + 3) = "Unique files"
x.Range("A" & UBound(arrd, 2) + 4) = "Path"
x.Range("B" & UBound(arrd, 2) + 4) = "File name"
x.Range("C" & UBound(arrd, 2) + 4) = "Size"
x.Range("A" & UBound(arrd, 2) + 3 & ":C" & UBound(arrd, 2) + 4).Font.Bold = True
x.Range("A" & UBound(arrd, 2) + 5).Resize(UBound(arru, 2) + 1, UBound(arru, 1) + 1) =
Application.Transpose(arru)
 
x.Columns("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 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Range("A" & Lrow) = FolderPath
            ActiveSheet.Range("B" & Lrow) = Value
            ActiveSheet.Range("C" & Lrow) = FileLen(FolderPath & Value)
        End If
    End If
    Value = Dir
Loop
For Each Folder In Folders
    Recursive FolderPath & Folder & "\"
Next Folder
End Sub