VBA get file name and File extension

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
Office Version
  1. 2010
Platform
  1. Windows
Dear All master,

I just want the file name in column c and the extension in column d.


The result I want is marked in yellow.

this is my link : result.xlsm
file
Thanks

roykana
VBA Code:
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

Sub ListAllFilesInAllFolders2()
 
    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 (MyFileName), Key
            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.Items)
    Sheets("Files").[B1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Dear all master,
can anyone help me for the vba code?

Thanks
Roykana
 
Upvote 0
Dear all master,
can anyone help me for the vba code?

Thanks
Roykana
 
Upvote 0
Dear all master,
can anyone help me for the vba code?

Thanks
Roykana
 
Upvote 0
Dear all master,
can anyone help me for the vba code?

Thanks
Roykana
 
Upvote 0
Dear all master,
can anyone help me for the vba code?

Thanks
Roykana
 
Upvote 0
Dear all master,

can anyone help and provide a solution for the vba code?


thank you

Roykana
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,557
Latest member
richa mishra

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