Obtain Folder Names from a Windows Folder Directory

[OilEconomist]

Thanks in advance.

What do I need to adjust to get the folder names to paste into the Worksheet “Raname.Folders” as I am getting the message “No folders found!”

I believe the issue is with the following lines of code, but I am not sure how to fix them:

'Store the directory
            DirFolderRename = Sheets("Rename.Folders").Cells(2, 2).Value

and the following

Set objFolders = objFSO.GetFolder(DirFolderRename).SubFolders

I used the following post: VBA Code to List Folders in a Directory and adjusted it to where
(1) versus choosing the folder directory with a pop box, I enter the folder path in cell “B2”
(2) it will paste the folder names in column A starting in cell A6 within sheet “Rename.Folders”. Prior to making change (1), this, (2), worked fine, so this part of the code does not need to be adjusted.

I did not ask my question within the aforementioned post (see link) because it indicated “This question is 985 days old. Therefore you may not receive any assistance if you ask your own question in this thread. We recommend creating a new thread to ask your own question unless you'd like to discuss this particular question.”

Sub Folders_Get_Names()


    Dim objFSO As Object
    Dim objFolders As Object
    Dim objFolder As Object
    Dim DirFolderRename As String
    Dim arrFolders() As String
    Dim FolderCount As Long
    Dim FolderIndex As Long
    
    
        
    '____________________________________________________________________________________________________
    'Directory
   
        'Check to see if the directory has been entered
            If Sheets("Rename.Folders").Cells(2, 2).Value = "" Then
    
                MsgBox "The directory needs to be entered in cell B2."
        
                Exit Sub
    
            End If
    
        
        'Check to see if the directory has "\" at the end
            If Right(Sheets("Rename.Folders").Cells(2, 2).Value, 1) <> "\" Then
            
                MsgBox Range("B2").Value
    
                Sheets("Rename.Folders").Cells(2, 2).Value = Sheets("Rename.Folders").Cells(2, 2).Value & "\"
    
            End If
        
        
        'Store the directory
            DirFolderRename = Sheets("Rename.Folders").Cells(2, 2).Value
    
    
    
    
    '____________________________________________________________________________________________________
    
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolders = objFSO.GetFolder(DirFolderRename).SubFolders
    
            FolderCount = objFolders.Count
    
            If FolderCount > 0 Then
                ReDim arrFolders(1 To FolderCount)
                FolderIndex = 0
                
                For Each objFolder In objFolders
                    FolderIndex = FolderIndex + 1
                    arrFolders(FolderIndex) = objFolder.Name
                Next objFolder
        
                Sheets("Rename.Folders").Activate
        
                Range("A6").Resize(FolderCount).Value = Application.Transpose(arrFolders)
            Else
                MsgBox "No folders found!", vbExclamation
                
            End If
    
            Set objFSO = Nothing
            Set objFolders = Nothing
            Set objFolder = Nothing
    
End Sub

 

[OilEconomist]

Thanks in advance.

What do I need to adjust to get the folder names to paste into the Worksheet “Raname.Folders” as I am getting the message “No folders found!”

I believe the issue is with the following lines of code, but I am not sure how to fix them:

'Store the directory
            DirFolderRename = Sheets("Rename.Folders").Cells(2, 2).Value

and the following

Set objFolders = objFSO.GetFolder(DirFolderRename).SubFolders

I used the following post: VBA Code to List Folders in a Directory and adjusted it to where
(1) versus choosing the folder directory with a pop box, I enter the folder path in cell “B2”
(2) it will paste the folder names in column A starting in cell A6 within sheet “Rename.Folders”. Prior to making change (1), this, (2), worked fine, so this part of the code does not need to be adjusted.

I did not ask my question within the aforementioned post (see link) because it indicated “This question is 985 days old. Therefore you may not receive any assistance if you ask your own question in this thread. We recommend creating a new thread to ask your own question unless you'd like to discuss this particular question.”

Sub Folders_Get_Names()


    Dim objFSO As Object
    Dim objFolders As Object
    Dim objFolder As Object
    Dim DirFolderRename As String
    Dim arrFolders() As String
    Dim FolderCount As Long
    Dim FolderIndex As Long
   
   
       
    '____________________________________________________________________________________________________
    'Directory
  
        'Check to see if the directory has been entered
            If Sheets("Rename.Folders").Cells(2, 2).Value = "" Then
   
                MsgBox "The directory needs to be entered in cell B2."
       
                Exit Sub
   
            End If
   
       
        'Check to see if the directory has "\" at the end
            If Right(Sheets("Rename.Folders").Cells(2, 2).Value, 1) <> "\" Then
           
                MsgBox Range("B2").Value
   
                Sheets("Rename.Folders").Cells(2, 2).Value = Sheets("Rename.Folders").Cells(2, 2).Value & "\"
   
            End If
       
       
        'Store the directory
            DirFolderRename = Sheets("Rename.Folders").Cells(2, 2).Value
   
   
   
   
    '____________________________________________________________________________________________________
   
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolders = objFSO.GetFolder(DirFolderRename).SubFolders
   
            FolderCount = objFolders.Count
   
            If FolderCount > 0 Then
                ReDim arrFolders(1 To FolderCount)
                FolderIndex = 0
               
                For Each objFolder In objFolders
                    FolderIndex = FolderIndex + 1
                    arrFolders(FolderIndex) = objFolder.Name
                Next objFolder
       
                Sheets("Rename.Folders").Activate
       
                Range("A6").Resize(FolderCount).Value = Application.Transpose(arrFolders)
            Else
                MsgBox "No folders found!", vbExclamation
               
            End If
   
            Set objFSO = Nothing
            Set objFolders = Nothing
            Set objFolder = Nothing
   
End Sub

Apologies. I found my error. It was the fact that I chose a directory where I had just deleted all the folders and forgot that I did that.

This works fine as is.