updating code getting information of list all files to multiple columns based on month

Hasson

Active Member
Joined
Apr 8, 2021
Messages
401
Office Version
  1. 2016
Platform
  1. Windows
hi
I need some help from professional to update this code
VBA Code:
Sub GetFilesDetails()

' This macro will extract the list of the filenames from a folder as follows

' in column A= Files names

' in column B= Date Created

' in column C= Date Last Accessed

' in column D= Date Last Modified

Dim objFSO As Scripting.FileSystemObject

Dim myFolder As Scripting.Folder

Dim myFile As Scripting.File

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set myFolder = objFSO.GetFolder("C:\Users\PC CAP\Desktop\VV\")

Application.ScreenUpdating = False

''******************************************************************************

' these 2 code lines will clear the old data in Sheet? from columns A:D

' Row 1 is for the appropriate headers only

ThisWorkbook.Sheets("Sheet1").Range(Cells(2, 1), Cells(Rows.Count, 4)).ClearContents

R = 2

''********************************************************************

' Here we get the files details from folder and place them in the appropriate cells

For Each myFile In myFolder.Files

       ThisWorkbook.Sheets("Sheet1").Cells(R, 1).Value = myFile.Name

       ThisWorkbook.Sheets("Sheet1").Cells(R, 2).Value = myFile.DateCreated

       ThisWorkbook.Sheets("Sheet1").Cells(R, 3).Value = myFile.DateLastAccessed

       ThisWorkbook.Sheets("Sheet1").Cells(R, 4).Value = myFile.DateLastModified

       R = R + 1

Next myFile

'''************Resizing the columns width****************

ThisWorkbook.Sheets("Sheet1").Columns("A:D").EntireColumn.AutoFit

Application.ScreenUpdating = True

'' Optional Alert

MsgBox "Updated"

End Sub
the code brings all of information from COL A : D but what I want split theses information based on month in column D
so what the code does currently is
1.xlsm
ABCD
1file namefile creation datethe last entry datethe last modified date
2mm.xlsm06/29/2021 16:2407/01/2021 11:5106/29/2021 16:26
3mr excel.xlsx06/29/2021 16:0507/01/2021 15:0706/30/2021 16:26
4TR1.xlsx06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26
51.pdf06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26
62.pdf06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26
73.pdf06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26
84.pdf06/29/2021 16:2307/01/2021 11:5106/30/2021 16:26
95.pdf06/29/2021 16:2407/01/2021 11:5106/30/2021 16:26
106.pdf06/29/2021 16:2507/01/2021 11:5106/30/2021 16:26
117.pdf06/29/2021 16:2607/01/2021 11:5106/30/2021 16:26
128.pdf06/29/2021 16:2707/01/2021 11:5107/09/2021 16:26
139.pdf07/01/2021 16:2407/01/2021 11:5107/10/2021 16:26
1410.pdf07/02/2021 16:2507/01/2021 11:5107/11/2021 16:26
1511.pdf07/03/2021 16:2607/01/2021 11:5107/12/2021 16:26
1612.pdf07/04/2021 16:2707/01/2021 11:5107/13/2021 16:26
1713.pdf07/05/2021 16:2807/01/2021 11:5107/14/2021 16:26
1814.pdf07/06/2021 16:2907/01/2021 11:5107/15/2021 16:26
1915.pdf07/07/2021 16:2207/01/2021 11:5107/16/2021 16:26
2016.pdf07/08/2021 16:2007/01/2021 11:5107/17/2021 16:26
211.JPG08/01/2021 16:1807/01/2021 11:5108/18/2021 16:26
2218.JPG08/02/2021 16:1907/01/2021 11:5108/19/2021 16:26
2319.AVI08/03/2021 16:2207/01/2021 11:5108/20/2021 16:26
2420.pdf08/04/2021 16:2307/01/2021 11:5108/21/2021 16:26
2521.pdf08/05/2021 16:2407/01/2021 11:5108/22/2021 16:26
sheet1



and what I want
1.xlsm
ABCDEFGHIJKLMNOPQ
1
2JUNEJULYAUGUSTS
3ITEMfile namefile creation datethe last entry datethe last modified date ITEMfile namefile creation datethe last entry datethe last modified date ITEMfile namefile creation datethe last entry datethe last modified date
41mm.xlsm06/29/2021 16:2407/01/2021 11:5106/29/2021 16:2618.pdf06/29/2021 16:2707/01/2021 11:5107/09/2021 16:2611.JPG08/01/2021 16:1807/01/2021 11:5108/18/2021 16:26
52mr excel.xlsx06/29/2021 16:0507/01/2021 15:0706/30/2021 16:2629.pdf07/01/2021 16:2407/01/2021 11:5107/10/2021 16:26218.JPG08/02/2021 16:1907/01/2021 11:5108/19/2021 16:26
63TR1.xlsx06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26310.pdf07/02/2021 16:2507/01/2021 11:5107/11/2021 16:26319.AVI08/03/2021 16:2207/01/2021 11:5108/20/2021 16:26
741.pdf06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26411.pdf07/03/2021 16:2607/01/2021 11:5107/12/2021 16:26420.pdf08/04/2021 16:2307/01/2021 11:5108/21/2021 16:26
852.pdf06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26512.pdf07/04/2021 16:2707/01/2021 11:5107/13/2021 16:26521.pdf08/05/2021 16:2407/01/2021 11:5108/22/2021 16:26
963.pdf06/29/2021 16:1507/01/2021 15:0706/30/2021 16:26613.pdf07/05/2021 16:2807/01/2021 11:5107/14/2021 16:26
1074.pdf06/29/2021 16:2307/01/2021 11:5106/30/2021 16:26714.pdf07/06/2021 16:2907/01/2021 11:5107/15/2021 16:26
1185.pdf06/29/2021 16:2407/01/2021 11:5106/30/2021 16:26815.pdf07/07/2021 16:2207/01/2021 11:5107/16/2021 16:26
1296.pdf06/29/2021 16:2507/01/2021 11:5106/30/2021 16:26916.pdf07/08/2021 16:2007/01/2021 11:5107/17/2021 16:26
13107.pdf06/29/2021 16:2607/01/2021 11:5106/30/2021 16:26
14
ss

thanks in advance
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Try this macro.
VBA Code:
Public Sub List_Files_Details_by_Month()

    Dim FSO As Scripting.FileSystemObject
    Dim thisFolder As Scripting.Folder
    Dim thisFile As Scripting.File
    Dim filesArray As Object
    Dim i As Long
    Dim dateFile As String
    Dim parts As Variant
    Dim yearMonth As Long, prevYearMonth As Long
    Dim destCell As Range, c As Long, n As Long
    
    Set filesArray = CreateObject("System.Collections.ArrayList")
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set thisFolder = FSO.GetFolder("C:\Users\PC CAP\Desktop\VV\")
    
    For Each thisFile In thisFolder.Files
        dateFile = Join(Array(CDbl(thisFile.DateCreated), thisFile.Name, thisFile.DateLastAccessed, thisFile.DateLastModified), "|")
        filesArray.Add dateFile
    Next
    
    'Sort in ascending order of date created
    
    filesArray.Sort
    
    'Group by year month in sheet cells
    
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        .Cells.Clear
        Set destCell = .Range("A2")
    End With
    
    parts = Split(filesArray(0), "|")
    prevYearMonth = Format(CDate(parts(0)), "YYYYMM")
    n = 0
    c = 0
        
    destCell.Offset(-1, c + 2).Value = UCase(Format(CDate(parts(0)), "YYYY MMMM"))
    destCell.Offset(-1, c + 2).Font.Bold = True
    destCell.Offset(0, c).Resize(1, 5).Value = Array("Item", "File name", "Created", "Accessed", "Modified")
    destCell.Offset(0, c).Resize(1, 5).Font.Bold = True
    
    For i = 0 To filesArray.Count - 1
    
        parts = Split(filesArray(i), "|")
        yearMonth = Format(CDate(parts(0)), "YYYYMM")
        
        If yearMonth <> prevYearMonth Then
            destCell.Offset(0, c).Resize(1, 5).EntireColumn.AutoFit
            n = 0
            c = c + 6
            destCell.Offset(-1, c + 2).Value = UCase(Format(CDate(parts(0)), "YYYY MMMM"))
            destCell.Offset(-1, c + 2).Font.Bold = True
            destCell.Offset(0, c).Resize(1, 5).Value = Array("Item", "File name", "Created", "Accessed", "Modified")
            destCell.Offset(0, c).Resize(1, 5).Font.Bold = True
            prevYearMonth = yearMonth
        End If
        
        n = n + 1
        destCell.Offset(n, c).Resize(1, 5).Value = Array(n, parts(1), CDate(parts(0)), CDate(parts(2)), CDate(parts(3)))
    
    Next
    
    destCell.Offset(0, c).Resize(1, 5).EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub
 
Upvote 0
thanks but it gives automation error in this line
VBA Code:
 Set filesArray = CreateObject("System.Collections.ArrayList")
 
Upvote 0
If you search for that error with that specific CreateObject one of the solutions is to install .Net Framework 3.5. Otherwise a separate sort routine would be needed.
 
Upvote 0
thanks John for this great work . nobody do that except professional like you I appreciate your effort.
install .Net Framework 3.5
you're right . now it works but there are some problems . I try following your code which column splits data based on month but I failed .
as you see in my picture in last column MODIFIED DATE contains many months then should split each month individual based on column Modified but this is not happens .
also it should bring the files from subfolder but the code doesn't do that .
finally I forgot mentioned that and I'm sorry it should hyperlink the files and open .


1.xlsx
ABCDE
12021 JULY
2ItemFile nameCreatedAccessedModified
31PPD-1000.PDF07/05/2021 11:5807/05/2021 11:5803/30/2021 15:00
421.JPG07/10/2021 12:0007/10/2021 13:4406/10/2021 13:07
532.JPG07/10/2021 12:0007/10/2021 12:0005/20/2021 15:39
64AS-QW-1004.JPG07/10/2021 12:0007/10/2021 15:2606/08/2021 12:07
7511.pdf07/10/2021 15:2607/10/2021 15:2605/20/2021 12:25
86as.pdf07/10/2021 15:2607/10/2021 15:2605/18/2021 15:01
971.pdf07/10/2021 15:2607/10/2021 15:2605/18/2021 14:51
108purchase-order-template.xlsx07/10/2021 15:2807/10/2021 15:2804/15/2019 11:35
119purchase-order-template1 .xlsm07/10/2021 15:2807/10/2021 15:2804/25/2019 2:53
1210purchase-order-template1.xlsx07/10/2021 15:2807/10/2021 15:2804/17/2019 20:29
1311transfer data 1.xlsm07/10/2021 15:2807/10/2021 15:2806/18/2019 18:24
SHEET1
 
Upvote 0
I try following your code which column splits data based on month but I failed .
as you see in my picture in last column MODIFIED DATE contains many months then should split each month individual based on column Modified but this is not happens .
My mistake; the code groups the files in the specified folder by year and month of created date, but you want modified date.

also it should bring the files from subfolder but the code doesn't do that .
finally I forgot mentioned that and I'm sorry it should hyperlink the files and open .
Quite a bit more than you originally asked for then. Try this macro:
VBA Code:
Public Sub List_Files_Details_by_Month()

    Dim FSO As Scripting.FileSystemObject
    Dim filesArray As Object
    Dim i As Long
    Dim parts As Variant
    Dim yearMonth As Long, prevYearMonth As Long
    Dim destCell As Range, c As Long, n As Long
    Dim fileName As String
   
    Set filesArray = CreateObject("System.Collections.ArrayList")
  
    Get_Files_In_Folders "C:\Users\PC CAP\Desktop\VV", filesArray
   
    'Sort in ascending order of modified date
   
    filesArray.Sort
    'filesArray.Reverse  'descending order
   
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        .Cells.Clear
        Set destCell = .Range("A2")
    End With
   
    'List files grouped by year and month of modified date across sheet columns
       
    parts = Split(filesArray(0), "|")
    prevYearMonth = Format(CDate(parts(0)), "YYYYMM")
    n = 0
    c = 0
       
    destCell.Offset(-1, c + 2).Value = UCase(Format(CDate(parts(0)), "YYYY MMMM"))
    destCell.Offset(-1, c + 2).Font.Bold = True
    destCell.Offset(0, c).Resize(1, 5).Value = Array("Item", "File name", "Created", "Accessed", "Modified")
    destCell.Offset(0, c).Resize(1, 5).Font.Bold = True
   
    For i = 0 To filesArray.Count - 1
   
        parts = Split(filesArray(i), "|")
        yearMonth = Format(CDate(parts(0)), "YYYYMM")
       
        If yearMonth <> prevYearMonth Then
            'Autofit columns for previous year and month files and add column headings for current year and month files
            destCell.Offset(0, c).Resize(1, 5).EntireColumn.AutoFit
            n = 0
            c = c + 6
            destCell.Offset(-1, c + 2).Value = UCase(Format(CDate(parts(0)), "YYYY MMMM"))
            destCell.Offset(-1, c + 2).Font.Bold = True
            destCell.Offset(0, c).Resize(1, 5).Value = Array("Item", "File name", "Created", "Accessed", "Modified")
            destCell.Offset(0, c).Resize(1, 5).Font.Bold = True
            prevYearMonth = yearMonth
        End If
       
        'Put file number, file name and its 3 dates in cells across 5 columns
        n = n + 1
        fileName = Mid(parts(1), InStrRev(parts(1), "\") + 1)
        destCell.Offset(n, c).Resize(1, 5).Value = Array(n, fileName, CDate(parts(2)), CDate(parts(3)), CDate(parts(0)))
               
        'Link file name cell to actual file
        destCell.Offset(n, c + 1).Parent.Hyperlinks.Add Anchor:=destCell.Offset(n, c + 1), Address:=parts(1), TextToDisplay:=fileName
   
    Next
   
    destCell.Offset(0, c).Resize(1, 5).EntireColumn.AutoFit
   
    Application.ScreenUpdating = True
   
    MsgBox "Done"

End Sub


Private Sub Get_Files_In_Folders(folderPath As String, filesArray As Object)

    Static FSO As Object
    Dim thisFolder As Object, subfolder As Object, thisFile As Object
    Dim dateFile As String
   
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
  
    Set thisFolder = FSO.GetFolder(folderPath)
  
    'Loop through all files in this folder and add to filesArray
  
    For Each thisFile In thisFolder.Files
        'Create string with full file name and 3 dates separated by "|" and add to filesArray.  First part of string is the file's
        'modified date as a decimal number, which allows filesArray to be sorted by that date
        dateFile = Join(Array(CDbl(thisFile.DateLastModified), thisFile.Path, thisFile.DateCreated, thisFile.DateLastAccessed), "|")
        filesArray.Add dateFile
    Next
   
    'Get files in subfolders of this folder
   
    For Each subfolder In thisFolder.SubFolders
        Get_Files_In_Folders subfolder.Path, filesArray
    Next

End Sub
 
Upvote 0
amazing ! but the code clear the formatting and borders also I wouldn't the underline when hyperlink
I would like this
MX.xlsm
AGAHAIAJAKALAMANAOAP
12021 APRIL2021 JULY
2CreatedAccessedModifiedItemFile nameCreatedAccessedModified
37/10/2021 23:397/10/2021 23:394/4/2021 17:361.No.Sudden.Move.2021.WEB-DL.1080p.x264.mp4][EgyBest].No.Sudden.Move.2021.WEB-DL.1080p.x264.mp47/10/2021 23:367/10/2021 23:377/6/2021 23:59
47/10/2021 23:397/10/2021 23:394/21/2021 11:032test.xlsm7/10/2021 23:367/10/2021 23:367/8/2021 20:55
57/10/2021 23:397/10/2021 23:394/21/2021 12:393test (1).xlsm7/10/2021 23:367/10/2021 23:367/8/2021 20:55
647/10/2021 23:377/10/2021 23:377/9/2021 14:40
SHEET5

thanks again
 
Upvote 0
but the code clear the formatting and borders also I wouldn't the underline when hyperlink

I have updated the macro to apply some cell formatting and borders. If this isn't correct, record a macro with the required formatting and another for the borders and incorporate the recorded code into the macro. The underline is standard for Excel hyperlinks and can't be removed.
VBA Code:
Public Sub List_Files_Details_By_Month()

    Dim FSO As Scripting.FileSystemObject
    Dim filesArray As Object
    Dim i As Long
    Dim parts As Variant
    Dim yearMonth As Long, prevYearMonth As Long
    Dim destCell As Range, c As Long, n As Long
    Dim fileName As String
    
    Set filesArray = CreateObject("System.Collections.ArrayList")
   
    Get_Files_In_Folders "C:\Users\PC CAP\Desktop\VV", filesArray
    
    'Sort in ascending order of modified date
    
    filesArray.Sort
    'filesArray.Reverse  'descending order
    
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet2")
        .Cells.Clear
        Set destCell = .Range("A2")
    End With
    
    'List files grouped by year and month of modified date across sheet columns
        
    parts = Split(filesArray(0), "|")
    prevYearMonth = Format(CDate(parts(0)), "YYYYMM")
    n = 0
    c = 0
        
    Cell_Headings destCell.Offset(, c), CDate(parts(0))
    
    For i = 0 To filesArray.Count - 1
    
        parts = Split(filesArray(i), "|")
        yearMonth = Format(CDate(parts(0)), "YYYYMM")
        
        If yearMonth <> prevYearMonth Then
            'Autofit columns for previous year and month files and add column headings for current year and month files
            destCell.Offset(, c).Resize(1, 5).EntireColumn.AutoFit
            Cell_Borders destCell.Offset(, c).Resize(n + 1, 5)
            n = 0
            c = c + 6
            Cell_Headings destCell.Offset(, c), CDate(parts(0))
            prevYearMonth = yearMonth
        End If
        
        'Put file number, file name and its 3 dates in cells across 5 columns
        n = n + 1
        fileName = Mid(parts(1), InStrRev(parts(1), "\") + 1)
        'Debug.Print n; parts(1), fileName, CDate(parts(2)), CDate(parts(3)), CDate(parts(0))
        destCell.Offset(n, c).Resize(1, 5).Value = Array(n, fileName, CDate(parts(2)), CDate(parts(3)), CDate(parts(0)))
                
        'Link file name cell to actual file
        destCell.Offset(n, c + 1).Parent.Hyperlinks.Add Anchor:=destCell.Offset(n, c + 1), Address:=parts(1), TextToDisplay:=fileName
    
    Next
    
    destCell.Offset(, c).Resize(1, 5).EntireColumn.AutoFit
    Cell_Borders destCell.Offset(, c).Resize(n + 1, 5)
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub


Private Sub Get_Files_In_Folders(folderPath As String, filesArray As Object)

    Static FSO As Object
    Dim thisFolder As Object, subfolder As Object, thisFile As Object
    Dim dateFile As String
    
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
   
    Set thisFolder = FSO.GetFolder(folderPath)
   
    'Loop through all files in this folder and add to filesArray
   
    For Each thisFile In thisFolder.Files
        'Create string with full file name and 3 dates separated by "|" and add to filesArray.  First part of string is the file's
        'modified date as a decimal number, which allows filesArray to be sorted by that date
        dateFile = Join(Array(CDbl(thisFile.DateLastModified), thisFile.Path, thisFile.DateCreated, thisFile.DateLastAccessed), "|")
        filesArray.Add dateFile
    Next
    
    'Get files in subfolders of this folder
    
    For Each subfolder In thisFolder.SubFolders
        Get_Files_In_Folders subfolder.Path, filesArray
    Next

End Sub


Private Sub Cell_Headings(startCell As Range, dateHeading As Date)

    With startCell.Offset(-1, 2)
        .Value = UCase(Format(dateHeading, "YYYY MMMM"))
        .Font.Bold = True
        .HorizontalAlignment = xlRight
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 255
        End With
    End With
    
    With startCell.Resize(1, 5)
        .Value = Array("Item", "File name", "Created", "Accessed", "Modified")
        .Font.Bold = True
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.149998474074526
            .PatternTintAndShade = 0
        End With
    End With

End Sub


Private Sub Cell_Borders(block As Range)

    Dim borderPos As Variant
    
    With block
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
    End With
    For Each borderPos In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
        With block.Borders(borderPos)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    Next
    
End Sub
 
Upvote 0
Solution
you're super great!
thanks so much for achieve this hard work to my project;)
 
Upvote 0
The underline is standard for Excel hyperlinks and can't be removed.
I would tell you . I succedded after many tries . I added this lin
VBA Code:
ActiveSheet.UsedRange.Font.Underline = xlUnderlineStyleNone
under this line
Code:
 destCell.Offset(n, c + 1).Parent.Hyperlinks.Add Anchor:=destCell.Offset(n, c + 1), Address:=parts(1), TextToDisplay:=fileName
thanks again for every thing
 
Upvote 0

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,631
Latest member
a_potato

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