• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

i need help with vba excel code for bring file's name from folder

M

mohamedtaha500

New Member
hello every one
i use this code to bring files's name have .doc from exact folder and subfolder from path which i put in code and put the data in excel sheet
the code is work great
but the problem is i need also date modified for every file but i can't edit on code

Code: 
Sub ListAllFilesInAllFolders()
Application.Calculation = xlCalculationManual
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            ActiveSheet.DisplayPageBreaks = False
    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, rrr As Long
  
    On Error Resume Next
        lastrow = Sheet2.Range("a" & Rows.Count).End(xlUp).Row
        Sheet2.Range("a2", "a" & lastrow + 1).ClearContents
        MyPath = Sheet1.Cells(2, 1).Value & "\"

    Set objFolder = Nothing
    Set objShell = Nothing

  
    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
  

    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.doc*")
        Do While MyFileName <> ""
            AllFiles.Add (Key & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    lastrow = Sheet2.Range("a" & Rows.Count).End(xlUp).Row + 1

    Sheet2.Cells(lastrow, 1).Resize(UBound(AllFiles.keys) + 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
    Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.EnableEvents = True
         ActiveSheet.DisplayPageBreaks = True
End Sub
 
If I correctly understood your request, have a try with what I came up with:
Code: 
Option Explicit
Sub ListAllFilesInAllFolders()
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i      As Integer
    Dim AllFolders As Object, AllFiles As Object
    Dim lastrow As Long, Key As Variant
    Dim FSO    As Object, AllDates As Object      '<- added
    Set FSO = CreateObject("Scripting.FileSystemObject") '<- added
    Set AllDates = CreateObject("Scripting.Dictionary") '<- added
    Application.ScreenUpdating = False
    On Error Resume Next
    lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
    Sheets(2).Range("A2", "A" & lastrow + 1).ClearContents
    MyPath = Sheets(1).Cells(2, 1).Value & "\"
    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
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.doc*")
        Do While MyFileName <> ""
            AllFiles.Add (Key & MyFileName), ""
            AllDates.Add (Format(FSO.GetFile(Key & MyFileName).DateLastModified, "dd/mm/yyyy hh:mm:ss")), "" '<- added
            MyFileName = Dir
        Loop
    Next
    lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets(2).Cells(lastrow, 1).Resize(UBound(AllFiles.keys) + 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Sheets(2).Cells(lastrow, 2).Resize(UBound(AllDates.keys) + 1) = WorksheetFunction.Transpose(AllDates.keys) '<- added
    Set AllFolders = Nothing
    Set AllFiles = Nothing
    Set FSO = Nothing                             '<- added
    Set AllDates = Nothing                        '<- added
    Application.ScreenUpdating = True
    MsgBox "Done!"                                '<- added
End Sub
 
rollis13 said:
If I correctly understood your request, have a try with what I came up with:
Code: 
Option Explicit
Sub ListAllFilesInAllFolders()
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i      As Integer
    Dim AllFolders As Object, AllFiles As Object
    Dim lastrow As Long, Key As Variant
    Dim FSO    As Object, AllDates As Object      '<- added
    Set FSO = CreateObject("Scripting.FileSystemObject") '<- added
    Set AllDates = CreateObject("Scripting.Dictionary") '<- added
    Application.ScreenUpdating = False
    On Error Resume Next
    lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
    Sheets(2).Range("A2", "A" & lastrow + 1).ClearContents
    MyPath = Sheets(1).Cells(2, 1).Value & "\"
    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
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.doc*")
        Do While MyFileName <> ""
            AllFiles.Add (Key & MyFileName), ""
            AllDates.Add (Format(FSO.GetFile(Key & MyFileName).DateLastModified, "dd/mm/yyyy hh:mm:ss")), "" '<- added
            MyFileName = Dir
        Loop
    Next
    lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheets(2).Cells(lastrow, 1).Resize(UBound(AllFiles.keys) + 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Sheets(2).Cells(lastrow, 2).Resize(UBound(AllDates.keys) + 1) = WorksheetFunction.Transpose(AllDates.keys) '<- added
    Set AllFolders = Nothing
    Set AllFiles = Nothing
    Set FSO = Nothing                             '<- added
    Set AllDates = Nothing                        '<- added
    Application.ScreenUpdating = True
    MsgBox "Done!"                                '<- added
End Sub
Click to expand...

i'm sorry sir the code is not working
there is no debug but the excel file is freezing

also i try to open locals window and press f8 to figure out what happen but i think it's not working like i need

if you see the attachment you will know what i need the result of my code on coulmn a like photo
i need also date modified for each file on column b
 

Attachments

  • 11111.jpg
    11111.jpg
    189.2 KB · Views: 6
mohamedtaha500 said:
if you see the attachment you will know what i need the result of my code on coulmn a like photo i need also date modified for each file on column b
Click to expand...
This is what you should achieve with my edits. How many files do you plan to list? Test the macro in a new file and choose a folder with fewer files to list.
 
rollis13 said:
This is what you should achieve with my edits. How many files do you plan to list? Test the macro in a new file and choose a folder with fewer files to list.
Click to expand...

greet
now we took one step to forward
i edited some line about sheet name and my bath
and it seems start to work
but brought the date for first file only
i atteched photo for sheet
also photo for code locals window
it is seems the item for AllFiles is increase
but the item for AllDates in stop on one item
 

Attachments

  • 11111.jpg
    11111.jpg
    268.5 KB · Views: 6
  • 22222.jpg
    22222.jpg
    179.7 KB · Views: 6
The error detection code is covering the reason. There is an issue in the code I used because when it finds the same date in different files it skips the output (On Error Resume Next). Update (open and save) the files without date in your list, launch the macro and you will see what I mean.
No idea why this happens, it's beyond my knowledge.
 
thanks very much sir
actually you help me to solve my problem
also i figured out what should to do
i will add one more properties to lastdatemodifed like name to get unique key depending on file name like this
Code: 
AllDates.Add (Format(FSO.GetFile(Key & MyFileName).DateLastModified, "dd/mm/yyyy hh:mm:ss") & _
FSO.GetFile(Key & MyFileName).Name), ""

then i will split the text

thanks sir
 

Attachments

  • 11111.jpg
    11111.jpg
    198.8 KB · Views: 3
I have found other file that error-out (for some reason) so your solution isn't resolutive. In case of error, instead of using On Error Resume Next, it would be best to fill the array AllDates with something like "Error Date" elsewise the array will have less items.
 
Have a try with this other approach with a 2-dimensional array instead of two arrays:
Code: 
Option Explicit
Sub ListAllFilesInAllFolders()
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i      As Integer
    Dim AllFolders As Object
    Dim lastrow As Long, Key As Variant
    Dim FSO    As Object
    Dim AllFiles() As String
    ReDim AllFiles(0 To 1, 0 To 1)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False
    On Error Resume Next
    lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
    Sheets(2).Range("A2", "B" & lastrow + 1).ClearContents
    MyPath = Sheets(1).Cells(2, 1).Value & "\"
    Set AllFolders = 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
    i = 0
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.doc*")
        Do While MyFileName <> ""
            AllFiles(0, i) = Key & MyFileName
            AllFiles(1, i) = Format(FSO.GetFile(Key & MyFileName).DateLastModified, "dd/mm/yyyy hh:mm:ss")
            ReDim Preserve AllFiles(UBound(AllFiles), UBound(AllFiles) + i)
            i = i + 1
            MyFileName = Dir
        Loop
    Next
    lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1
    For i = LBound(AllFiles, 1) To UBound(AllFiles, 2)
        Sheets(2).Cells(lastrow + i, 1) = AllFiles(0, i)
        Sheets(2).Cells(lastrow + i, 2) = AllFiles(1, i)
    Next i
    Set AllFolders = Nothing
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub
 
You must log in or register to reply here.
Back
Top