Macro to List Folders excluding Data Stamp within E:\Cobian

[howard]

I have code to list folders excluding the date stamp eg E:\Cobian\ProgramData 2024-10-25 02;11;55 (Full) i.e. list only E:\Cobian\ProgramData in Col F on sheet subfolders and show no.of folders for each folder name in Col G

My code is also counting the sub-folders within these folders which I do not require eg application data with Program Data

It would be appreciated if someone could kindly amend my code

 Sub ListUniqueFoldersAndCounts()
    Dim folderPath As String
    Dim fso As Object
    Dim folderDict As Object
    Dim subFolder As Object
    Dim baseName As String
    Dim ws As Worksheet
    Dim rowNum As Long
    Dim key As Variant
    Dim folder As Object
    Dim folderName As String
    
    ' Define the folder path (root folder)
    folderPath = "E:\Cobian"
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Subfolders")
    
    ' Initialize FileSystemObject and Dictionary
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folderDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through each folder in the root directory (skip subfolders and sub-subfolders)
    For Each folder In fso.GetFolder(folderPath).SubFolders
        ' Get the folder name without date/time or extra text (split on space, take the first part)
        folderName = folder.Name
        baseName = Trim(Split(folderName, " ")(0)) ' This will take only the first part of the folder name before the timestamp
        
        ' Ensure the dictionary for this base name exists
        If Not folderDict.exists(baseName) Then
            folderDict.Add baseName, 0 ' Initialize with 0 count
        End If
        
        ' Increment the folder count for each base name (only count first-level folders)
        folderDict(baseName) = folderDict(baseName) + 1
    Next folder
    
    ' Clear previous data in columns F and G
    ws.Range("F:G").ClearContents
    
    ' List unique folder names in Column F and their counts in Column G
    rowNum = 2 ' Start from row 2
    For Each key In folderDict.Keys
        ws.Cells(rowNum, 6).Value = key ' List base name in Column F
        ws.Cells(rowNum, 7).Value = folderDict(key) ' Folder count in Column G
        rowNum = rowNum + 1
    Next key
    
    MsgBox "Unique folders and their counts have been listed.", vbInformation
End Sub [code]