Excel VBA: List Files of Folder/Subfolder & Rename Files with new filename

harky

Active Member
Hi need some help, i try to search around the forum but seen not able to find one i want.

Step 1 (list filename of Folder & SubFolder), there will be a POP-UP and ask user to select the path
Step 2 (rename filename base on col C) & Status update on Col D

Isit gd ideal to display ext?


ABCD
PathOriginal FilenameNew FilenameStatus
Renamed / Error

<tbody>
</tbody>
 

harky

Active Member
Step 2

rename filename base on col C, also base on the path at col A

So this will not rename the folder or sub-folder?
 

harky

Active Member
I want to do it in excel as I had many file to rename.. And it much easy.
 
Last edited:

harky

Active Member
Step 2 (something like this but not really the one i want.

Code:
Public Sub renameWorkbook()
    For r = 2 To Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
        filePath = Range("A" & r)
        oldFileNm = Range("B" & r)
        newFileNm = Range("C" & r)
        Name filePath & oldFileNm As filePath & newFileNm
    Next r
End Sub
 

harky

Active Member
Hi Sorry..

I make a change


Hi need some help, i try to search around the forum but seen not able to find one i want.

Step 1: List filename with ext on Folder & SubFolder with path


Step 2: Rename path+filename base on col B) & Status update on Col C

Isit gd ideal to display ext?


Step 2
ABCD
Original
Path + Filename
NEW
Path + Filename
Status
C:\Users\AAA\Downloads\ABC.xlsmC:\Users\AAA\Downloads\123.xlsm

<tbody>
</tbody>
 
Last edited:

harky

Active Member
I found a code that will list the part 1.


but it has error..
@ Set Folder = OBJ.GetFolder(strPath)

part 1 Code

AB
Original FileNamePath
ABC.xlsmC:\Users\AAA\Downloads\ABC.xlsm

<tbody>
</tbody>


Code:
Function UserGetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show - 1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    UserGetFolder = sItem
    Set fldr = Nothing
End Function




Sub GetFolder()


Range("A:B").ClearContents
Range("A1").Value = "Original FilName"
Range("B1").Value = "Path"
Range("A1").Select


Dim strPath As String
'strPath = "C:\"
strPath = UserGetFolder


Dim OBJ As Object, Folder As Object, File As Object




Set OBJ = CreateObject("Scripting.FileSystemObject")
[COLOR=#ff0000]Set Folder = OBJ.GetFolder(strPath)[/COLOR]


Call ListFiles(Folder)


Dim SubFolder As Object


For Each SubFolder In Folder.SubFolders
    Call ListFiles(SubFolder)
    Call GetSubFolders(SubFolder)
Next SubFolder


Range("A1").Select


End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Sub ListFiles(ByRef Folder As Object)


For Each File In Folder.Files
        ActiveCell.Offset(1, 0).Select
        ActiveCell = File.Name
        ActiveCell.Offset(0, 1) = File.Path
Next File


End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Sub GetSubFolders(ByRef SubFolder As Object)


Dim FolderItem As Object


For Each FolderItem In SubFolder.SubFolders
    Call ListFiles(FolderItem)
    Call GetSubFolders(FolderItem)
Next FolderItem


End Sub
 
Last edited:

harky

Active Member
I reply my own question. Manage to get it fix :)

Will be great if someone can tell me how to get delete or hid Thumbs.db

Code:
Sub ListFilesFromAllFolder()


Range("A:B").ClearContents
Range("A1").Value = "Original File Name"
Range("B1").Value = "Path"
Range("A1").Select


Dim strPath As String
'strPath = "C:\"
strPath = UserGetFolder


Dim OBJ As Object
Dim Folder As Object
Dim File As Object
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)


Call ListFiles(Folder)


Dim SubFolder As Object


For Each SubFolder In Folder.SubFolders
    Call ListFiles(SubFolder)
    Call GetSubFolders(SubFolder)
Next SubFolder


Columns("A:L").AutoFit
Range("A1").Select


End Sub


Private Sub ListFiles(ByRef Folder As Object)


For Each File In Folder.Files
        ActiveCell.Offset(1, 0).Select
        ActiveCell = File.Name
        ActiveCell.Offset(0, 1) = File.Path
Next File


End Sub


Private Sub GetSubFolders(ByRef SubFolder As Object)


Dim FolderItem As Object


For Each FolderItem In SubFolder.SubFolders
    Call ListFiles(FolderItem)
    Call GetSubFolders(FolderItem)
Next FolderItem


End Sub


Function UserGetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    UserGetFolder = sItem
    Set fldr = Nothing
End Function

I found a code that will list the part 1.


but it has error..
@ Set Folder = OBJ.GetFolder(strPath)

part 1 Code

AB
Original FileNamePath
ABC.xlsmC:\Users\AAA\Downloads\ABC.xlsm

<tbody>
</tbody>


Code:
Function UserGetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show - 1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    UserGetFolder = sItem
    Set fldr = Nothing
End Function




Sub GetFolder()


Range("A:B").ClearContents
Range("A1").Value = "Original FilName"
Range("B1").Value = "Path"
Range("A1").Select


Dim strPath As String
'strPath = "C:\"
strPath = UserGetFolder


Dim OBJ As Object, Folder As Object, File As Object




Set OBJ = CreateObject("Scripting.FileSystemObject")
[COLOR=#ff0000]Set Folder = OBJ.GetFolder(strPath)[/COLOR]


Call ListFiles(Folder)


Dim SubFolder As Object


For Each SubFolder In Folder.SubFolders
    Call ListFiles(SubFolder)
    Call GetSubFolders(SubFolder)
Next SubFolder


Range("A1").Select


End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Sub ListFiles(ByRef Folder As Object)


For Each File In Folder.Files
        ActiveCell.Offset(1, 0).Select
        ActiveCell = File.Name
        ActiveCell.Offset(0, 1) = File.Path
Next File


End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Sub GetSubFolders(ByRef SubFolder As Object)


Dim FolderItem As Object


For Each FolderItem In SubFolder.SubFolders
    Call ListFiles(FolderItem)
    Call GetSubFolders(FolderItem)
Next FolderItem


End Sub
 
Last edited:

Some videos you may like

This Week's Hot Topics

  • Get External Data (long shot question!)
    This is likely a long shot but I am wondering if it is at all possible for Excel to somehow 'change' the contents of a URL that is being linked to...
  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • Cell Formatting
    Good Morning, I need to format a few different cells in the following manners: A1 has to always add a colon (:) after whatever is typed in by a...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • Workbook_Change stopped working !
    I am working on an app to speed up & automate processing of Credit Cards statements. After data is input from a CSV file, it is presented to the...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
Top