VBA to extract most Used Folders

H

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,595
Office Version
  1. 2021
Platform
  1. Windows
I have tried to write VBA code to extract the 10 most used folders in Windows except Outlook folders, sub-folders and program folders

However, I get compile error : for each control variable must be variant or object and the code below is highlighted


Code: 
 For Each folderPath In GetFoldersOnDrive("C:\", False)
It would be appreciated if someone could amend my code



See full code below



Code: 
 Sub MostUsedFolders()
    
    Dim dict As Object
    Dim arr() As Variant
    Dim i As Long
    Dim rng As Range
    Dim folderPath As String
    Dim folder As Object
    
    'Create a dictionary to hold the folder paths and their usage count
    Set dict = CreateObject("Scripting.Dictionary")
    
    'Loop through each folder on the C:\ drive
    For Each folderPath In GetFoldersOnDrive("C:\", False)
        Set folder = CreateObject("Scripting.FileSystemObject").GetFolder(folderPath)
        If Not IsOutlookFolder(folder) And Not IsProgramFolder(folder) Then
            CountItems folder, dict
        End If
    Next folderPath
    
    'Put the folder paths and their usage count into an array
    ReDim arr(1 To dict.Count, 1 To 2)
    i = 1
    For Each folderPath In dict
        arr(i, 1) = folderPath
        arr(i, 2) = dict(folderPath)
        i = i + 1
    Next folderPath
    
    'Sort the array by the usage count in descending order
    SortArray arr
    
    'Clear column A
    Set rng = Range("A1", Range("A1").End(xlDown))
    rng.ClearContents
    
    'Paste the folder paths into column A
    Set rng = Range("A1").Resize(UBound(arr, 1), 1)
    rng.Value = arr
    
End Sub

Function GetFoldersOnDrive(drivePath As String, includeSubfolders As Boolean) As Collection
    
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim folders As New Collection
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(drivePath)
    
    For Each subFolder In folder.subFolders
        If includeSubfolders Then
            folders.Add subFolder.Path
        Else
            folders.Add subFolder.Path, subFolder.Path
        End If
    Next subFolder
    
    Set GetFoldersOnDrive = folders
    
End Function

Function CountItems(folder As Object, dict As Object)
    
    Dim item As Object
    Dim key As String
    
    'Loop through each item in the folder
    For Each item In folder.Files
        'If the item is a file, add its parent folder path to the dictionary
        key = folder.Path
        If dict.Exists(key) Then
            dict(key) = dict(key) + 1
        Else
            dict.Add key, 1
        End If
    Next item
    
End Function

Function IsOutlookFolder(folder As Object) As Boolean
    Dim folderName As String
    folderName = folder.Name
    IsOutlookFolder = folderName = "Outlook" Or folderName = "Outlook Files" Or folderName = "Local Settings" Or folderName = "Roaming" Or folderName = "AppData" Or folderName = "Microsoft" Or folderName = "Office"
End Function

Function IsProgramFolder(folder As Object) As Boolean
    Dim folderName As String
    folderName = folder.Name
    IsProgramFolder = folderName = "Program Files" Or folderName = "Program Files (x86)" Or folderName = "Windows"
End Function

Sub SortArray(arr() As Variant)

Dim i As Long
Dim j As Long
Dim temp As Variant

For i = LBound(arr, 1) To UBound(arr, 1) - 1
    For j = i + 1 To UBound(arr, 1)
        If arr(j, 2) > arr(i, 2) Then
            temp = arr(j, 1)
            arr(j, 1) = arr(i, 1)
            arr(i, 1) = temp
            temp = arr(j, 2)
            arr(j, 2) = arr(i, 2)
            arr(i, 2) = temp
        End If
    Next j
Next i

End Sub
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
If GetFoldersOnDrive (which appears to be a custom function that you are not showing) returns an object, you cannot set the return value of the function to a string variable. That's what your error description suggests to me.
 
Upvote 0
I have managed to get this to work now, but only need the 10 most used folders to be copied in Col A. It would be appreciatted if someone could kindly amend my code

Code: 
 Function GetFoldersOnDrive(drivePath As String, includeSubfolders As Boolean) As Collection
    
    Dim FSO As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim folders As New Collection
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(drivePath)
    
    For Each subFolder In folder.subFolders
        If includeSubfolders Then
            folders.Add subFolder.Path
        Else
            folders.Add subFolder.Path, subFolder.Path
        End If
    Next subFolder
    
    Set GetFoldersOnDrive = folders
    
End Function

Function CountItems(folder As Object, dict As Object)
    
    Dim item As Object
    Dim key As String
    
    'Loop through each item in the folder
    On Error Resume Next ' Ignore any errors that occur while accessing files and folders
    For Each item In folder.Files
        'If the item is a file, add its parent folder path to the dictionary
        key = folder.Path
        If dict.Exists(key) Then
            dict(key) = dict(key) + 1
        Else
            dict.Add key, 1
        End If
    Next item
    
End Function




Function IsOutlookFolder(folder As Object) As Boolean
    Dim folderName As String
    folderName = folder.Name
    IsOutlookFolder = folderName Like "Outlook*" Or folderName Like "Microsoft*" Or folderName Like "Office*"
End Function

Function IsProgramFolder(folder As Object) As Boolean
    Dim folderName As String
    folderName = folder.Name
    IsProgramFolder = folderName Like "Program Files*" Or folderName = "Windows"
End Function

Sub MostUsedFolders()
    
    Dim dict As Object
    Dim arr() As Variant
    Dim i As Long
    Dim rng As Range
    Dim FolderPath As Variant ' Change the data type to Variant
    Dim folder As Object
    
    'Create a dictionary to hold the folder paths and their usage count
    Set dict = CreateObject("Scripting.Dictionary")
    
    'Loop through each folder on the C:\ drive
    For Each FolderPath In GetFoldersOnDrive("C:\", False)
        Set folder = CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath)
        If Not IsOutlookFolder(folder) And Not IsProgramFolder(folder) Then
            CountItems folder, dict
        End If
    Next FolderPath
    
    'Put the folder paths and their usage count into an array
    ReDim arr(1 To dict.Count, 1 To 2)
    i = 1
    For Each FolderPath In dict
        arr(i, 1) = FolderPath
        arr(i, 2) = dict(FolderPath)
        i = i + 1
    Next FolderPath
    
    'Sort the array by the usage count in descending order
    SortArray arr
    
    'Clear column A
    Set rng = Range("A1", Range("A1").End(xlDown))
    rng.ClearContents
    
    'Paste the folder paths into column A
    Set rng = Range("A1").Resize(UBound(arr, 1), 1)
    rng.Value = arr
    
End Sub

Sub SortArray(arr() As Variant)
    Dim i As Long
    Dim j As Long
    Dim temp As Variant
    
    For i = LBound(arr, 1) To UBound(arr, 1) - 1
        For j = i + 1 To UBound(arr, 1)
            If arr(j, 2) > arr(i, 2) Then
                temp = arr(j, 1)
                arr(j, 1) = arr(i, 1)
                arr(i, 1) = temp
                temp = arr(j, 2)
                arr(j, 2) = arr(i, 2)
                arr(i, 2) = temp
            End If
        Next j
    Next i
End Sub
 
Upvote 0
Here is my amended code to extract the 10 most used folders

Code: 
 Function GetFoldersOnDrive(drivePath As String, includeSubfolders As Boolean) As Collection
    
    Dim FSO As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim folders As New Collection
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(drivePath)
    
    For Each subFolder In folder.subFolders
        If includeSubfolders Then
            folders.Add subFolder.Path
        Else
            folders.Add subFolder.Path, subFolder.Path
        End If
    Next subFolder
    
    Set GetFoldersOnDrive = folders
    
End Function

Function CountItems(folder As Object, dict As Object)
    
    Dim item As Object
    Dim key As String
    
    'Loop through each item in the folder
    On Error Resume Next ' Ignore any errors that occur while accessing files and folders
    For Each item In folder.Files
        'If the item is a file, add its parent folder path to the dictionary
        key = folder.Path
        If dict.Exists(key) Then
            dict(key) = dict(key) + 1
        Else
            dict.Add key, 1
        End If
    Next item
    
End Function

Function IsOutlookFolder(folder As Object) As Boolean
    Dim folderName As String
    folderName = folder.Name
    IsOutlookFolder = folderName Like "Outlook*" Or folderName Like "Microsoft*" Or folderName Like "Office*"
End Function

Function IsProgramFolder(folder As Object) As Boolean
    Dim folderName As String
    folderName = folder.Name
    IsProgramFolder = folderName Like "Program Files*" Or folderName = "Windows"
End Function

Sub MostUsedFolders()
    
    Dim dict As Object
    Dim arr() As Variant
    Dim i As Long
    Dim rng As Range
    Dim FolderPath As Variant ' Change the data type to Variant
    Dim folder As Object
    
    'Create a dictionary to hold the folder paths and their usage count
    Set dict = CreateObject("Scripting.Dictionary")
    
    'Loop through each folder on the C:\ drive
    For Each FolderPath In GetFoldersOnDrive("C:\", False)
        Set folder = CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath)
        If Not IsOutlookFolder(folder) And Not IsProgramFolder(folder) Then
            CountItems folder, dict
        End If
    Next FolderPath
    
    'Put the folder paths and their usage count into an array
    ReDim arr(1 To dict.Count, 1 To 2)
    i = 1
    For Each FolderPath In dict
        arr(i, 1) = FolderPath
        arr(i, 2) = dict(FolderPath)
        i = i + 1
    Next FolderPath
    
    'Sort the array by the usage count in descending order
    SortArray arr
    
    'Clear column A
    Set rng = Range("A1", Range("A1").End(xlDown))
    rng.ClearContents
    
    'Get the top 10 most used folders
    Dim topFolders As New Collection
    For i = 1 To 10
        If i > UBound(arr, 1) Then Exit For
        topFolders.Add arr(i, 1)
    Next i
    
    'Paste the top 10 most used folders into column A
    Set rng = Range("A1").Resize(topFolders.Count, 1)
    For i = 1 To topFolders.Count
        rng.Cells(i, 1).Value = topFolders(i)
    Next i

End Sub

Sub SortArray(ByRef arr() As Variant)
    
    Dim temp As Variant
    Dim i As Long
    Dim j As Long
    
    For i = LBound(arr, 1) To UBound(arr, 1) - 1
        For j = i + 1 To UBound(arr, 1)
            If arr(j, 2) > arr(i, 2) Then
                temp = arr(j, 1)
                arr(j, 1) = arr(i, 1)
                arr(i, 1) = temp
                temp = arr(j, 2)
                arr(j, 2) = arr(i, 2)
                arr(i, 2) = temp
            End If
        Next j
    Next i
    
End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

mmn1000
  • Question Question
List folders and files
Replies
1
Views
777
Fuji
F
S
  • Question Question
Adding a new field to the results of my "list the folders inside a specific folder" code
Replies
2
Views
295
John_w
J
R
  • Solved
Go through subfolders, select matching files and copy a worksheet from each into a master file
2
Replies
17
Views
897
BatTodor
B
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
938
GarnesGambit
G
M
  • Question Question
Operational Risk Methodology on VBA
Replies
0
Views
81
Mazurofgod
M

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

Share this page

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
Back
Top