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

H

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
 
Sort by date Sort by votes
@John_w how apply loop throughout the all sheets I mean each month should be indivdually sheet

for instance first sheet is JAN, second sheet is FEB and so on the rest of sheets
 
Upvote 0

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
tubrak said:
how apply loop throughout the all sheets I mean each month should be indivdually sheet

for instance first sheet is JAN, second sheet is FEB and so on the rest of sheets
Click to expand...
Try this macro. All sheets named "YYYY MMM" (e.g. 2021 JAN) in the macro workbook are deleted and then the necessary sheets are added with the files listed for each year-month of the file modified dates.

VBA Code: 
Public Sub List_Files_Details_By_Month_In_Sheets()

    Dim wb As Workbook
    Dim filesArray As Object
    Dim i As Long
    Dim parts As Variant
    Dim yearMonth As Long, prevYearMonth As Long
    Dim destCell As Range, n As Long
    Dim fileName As String
   
    'Create sheets in this macro workbook
   
    Set wb = ThisWorkbook
   
    Set filesArray = CreateObject("System.Collections.ArrayList")
  
    Get_Files_In_Folders "C:\path\to\folder", filesArray
   
    'Sort in ascending order of modified date
   
    filesArray.Sort
    'filesArray.Reverse  'descending order
   
    If filesArray.Count > 0 Then
   
        Delete_Year_Month_Sheets wb

        'Group files by year month in separate sheets
       
        Application.ScreenUpdating = False
       
        parts = Split(filesArray(0), "|")
       
        'Add sheet for 1st year month
       
        Set destCell = Add_Sheet(wb, CDate(parts(0)))
        prevYearMonth = Format(CDate(parts(0)), "YYYYMM")
        n = 0

        For i = 0 To filesArray.Count - 1
       
            parts = Split(filesArray(i), "|")
            yearMonth = Format(CDate(parts(0)), "YYYYMM")
           
            If yearMonth <> prevYearMonth Then
               
                'Format current sheet for previous year month
               
                Format_Sheet destCell, n + 1
                               
                'Add sheet for current year month
               
                Set destCell = Add_Sheet(wb, CDate(parts(0)))
                prevYearMonth = yearMonth
                n = 0
               
            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).Resize(1, 5).Value = Array(n, fileName, CDate(parts(2)), CDate(parts(3)), CDate(parts(0)))
                   
            'Link file name (column B) cell to actual file
           
            destCell.Offset(n, 1).Parent.Hyperlinks.Add Anchor:=destCell.Offset(n, 1), Address:=parts(1), TextToDisplay:=fileName
       
        Next
       
        Format_Sheet destCell, n + 1
   
        Application.ScreenUpdating = True
       
        MsgBox "Done"
   
    Else
   
        MsgBox "There are no files in the folder", vbExclamation
   
    End If

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
   
    'Add files in subfolders of this folder
   
    For Each subfolder In thisFolder.SubFolders
        Get_Files_In_Folders subfolder.Path, filesArray
    Next

End Sub


Private Function Add_Sheet(wb As Workbook, sheetDate As Date) As Range

    Dim yearMonthSheet As Worksheet
    Dim sheetName As String
   
    'Add a sheet for the specified date named "YYYY MMM" with column headings and return the destination cell (A1)
   
    sheetName = UCase(Format(sheetDate, "YYYY MMM"))
   
    With wb
        On Error Resume Next
        Set yearMonthSheet = .Worksheets(sheetName)
        On Error GoTo 0
           
        If yearMonthSheet Is Nothing Then
            Set yearMonthSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            yearMonthSheet.Name = sheetName
        Else
            yearMonthSheet.Cells.Clear
        End If
    End With
   
    Set Add_Sheet = yearMonthSheet.Range("A1")
   
    With Add_Sheet.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 Function


Private Sub Format_Sheet(destCell As Range, numRows As Long)

    Dim borderPos As Variant

    'Autofit columns, add cell borders and remove hyperlink underlines
   
    With destCell
        .Resize(1, 5).EntireColumn.AutoFit
        With destCell.Resize(numRows, 5)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            For Each borderPos In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
                With .Borders(borderPos)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
            Next
        End With
        .Worksheet.UsedRange.Font.Underline = xlUnderlineStyleNone
    End With
   
End Sub


Private Sub Delete_Year_Month_Sheets(wb As Workbook)

    Dim regex As Object
    Dim yearMonthSheets As String
    Dim ws As Worksheet
   
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\d{4}\s(JAN|FEB|MAR|APR|MAY|JUN|JUL|AUG|SEP|OCT|NOV|DEC)"
   
    yearMonthSheets = ""
    For Each ws In wb.Worksheets
        If regex.test(ws.Name) Then yearMonthSheets = yearMonthSheets & ws.Name & "|"
    Next
   
    If yearMonthSheets <> "" Then
        Application.DisplayAlerts = False
        wb.Worksheets(Split(Left(yearMonthSheets, Len(yearMonthSheets) - 1), "|")).Delete
        Application.DisplayAlerts = True
    End If
   
End Sub
 
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
361
Cubist
Cubist
H
  • Solved
Find a subject that is in column "P" in columns "G" and "L" and export.
Replies
2
Views
252
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
359
leap out
L
L
  • Question Question
Formula Help with Count Number of Vessel Turnaround Trips monthly based on Criteria
Replies
1
Views
455
Lukma
L

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

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