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

H

Hasson

Active Member
Joined
Apr 8, 2021
Messages
406
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

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
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
Click to expand...
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
Hasson said:
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 .
Click to expand...
My mistake; the code groups the files in the specified folder by year and month of created date, but you want modified date.

Hasson said:
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 .
Click to expand...
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
Hasson said:
but the code clear the formatting and borders also I wouldn't the underline when hyperlink
Click to expand...

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.
Click to expand...
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
You must log in or register to reply here.

Similar threads

H
  • Question Question
copy some columns based on the value in column "A".
Replies
9
Views
365
Cubist
Cubist
H
  • Solved
Find a subject that is in column "P" in columns "G" and "L" and export.
Replies
2
Views
253
harzer
H
O
  • Question Question
MS Excel VBA Code - Simplest Way to Check if a Series of Dates is Between Two Dates and Enter Comment and Date in another Column
Replies
3
Views
1K
bebo021999
B
L
  • Question Question
export specific sheets based on sheets names list into column and same formatting
Replies
0
Views
362
leap out
L
L
  • Question Question
Formula Help with Count Number of Vessel Turnaround Trips monthly based on Criteria
Replies
1
Views
480
Lukma
L

Forum statistics

Threads
1,224,824
Messages
6,181,186
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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