[VBA]디렉토리 안의 파일 목록 구하기2

파일이 자주 추가되거나 삭제될때 사용하기 위해 기존의 버전을 업그레이드 했습니다.

To Do List: 메인함수 module화

'Force the explicit declaration of variables
Option Explicit

' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2017-Oct-28             Initial Release
' 2         2017-Oct-28             Enter the folder name
' 3         2017-Oct-29             Use File Dialog
' 4         2022-Dec-11             Copy Sheet
' 5         2022-Dec-12             Add DateCreated
' 6         2022-Dec-26             addRow, setRowCnt
' 7         2022-Dec-28             Add one line of summary for statistics
' 8         2023-Jan-10             Format month and day(date)
' 9         2023-Jan-19             Total File Size, walkaround for the compile error of format(date, "mm")
' **************************************************************************************


Sub ListFiles()

     'Set a reference to Microsoft Scripting Runtime by using
     'Tools > References in the Visual Basic Editor (Alt+F11)
     
     'Declare the variables
     Dim objFSO As FileSystemObject
     Dim objFolder As Folder
     Dim objFile As File
     Dim strPath As String
     Dim strFile As String
     Dim NextRow As Long
     Dim dblFileSize As Double
     Dim dblFileTotalSize As Double
     
     
     'Added Codes Begin
     Dim Msg As String
     
     Call clearContents
     
     'Open the file dialog
     With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            'MsgBox (.SelectedItems(1))
            strPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
     End With
  
     
     'Msg = "Write down the folder name, please: " & vbCr
     'Msg = Msg & "e.g. C:\Users\Steve\Documents\Vids\"
     'strPath = Trim(InputBox(Msg, "Input"))
  
     If right(strPath, 1) <> "\" Then strPath = strPath & "\"
     
     'Added Codes End
     
     'Create an instance of the FileSystemObject
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     
     'Get the folder
     Set objFolder = objFSO.GetFolder(strPath)
     
     'If the folder does not contain files, exit the sub
     If objFolder.Files.Count = 0 Then
         MsgBox "No files were found...", vbExclamation
         Exit Sub
     End If
     
     'Turn off screen updating
     Application.ScreenUpdating = False
     
     'Insert the headers for Columns A, B, C, and D
     Cells(1, "A").Value = "File Name"
     Cells(1, "B").Value = "Path"
     Cells(1, "C").Value = "Size"
     Cells(1, "D").Value = "Created Date"
     
     'Find the next available row
     NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
     
     'Loop through each file in the folder
     For Each objFile In objFolder.Files
     
         'List the name, size, and date/time of the current file
         Cells(NextRow, 1).Value = objFile.Name
         'Cells(NextRow, 2).Value = objFile.Path
         Cells(NextRow, 2).Value = objFile.ParentFolder
         'Cells(NextRow, 3).Value = objFile.Size
         dblFileSize = objFile.Size
         Cells(NextRow, 3).Value = dblFileSize
         'Cells(NextRow, 3).Value = format(Round(dblFileSize / 1000000, 0), "#,#") & " MB" 'Format(n, "#,#")

         Cells(NextRow, 4).Value = objFile.DateCreated
         
         'Determine the next row
         NextRow = NextRow + 1
         dblFileTotalSize = dblFileTotalSize + dblFileSize
     
     Next objFile
     
     'Change the width of the columns to achieve the best fit
     'Columns.AutoFit
     'Format Cells
     Range(Cells(2, 3), Cells(Rows.Count, "D").End(xlUp)).Select
     Selection.HorizontalAlignment = xlRight
     Range(Cells(2, 4), Cells(Rows.Count, "D").End(xlUp)).Select
     Selection.NumberFormatLocal = "yyyy-mm-dd hh:mm"
     Selection.HorizontalAlignment = xlCenter
     Range("A1").Select
     
    Call copySheet
    
    Dim searchCnt As Long
    Dim Cell As Range
    For Each Cell In ActiveSheet.UsedRange.Columns(1).Cells
        If InStr(Cell.Value, "_error_") > 0 Then
            searchCnt = searchCnt + 1
        End If
    Next Cell
    'MsgBox "searchCnt = " & searchCnt
    
    Call addRow
    Call addFilter
    Call setRowCnt(searchCnt, dblFileTotalSize)
    Range("A1").Select
    
    'Turn screen updating back on
    Application.ScreenUpdating = True
         
End Sub

Private Sub clearContents()
    Worksheets("listFiles").Range("A1").EntireColumn.EntireRow.clearContents
End Sub

Private Sub copySheet()
    'Sheets(1).Copy after:=Sheets(1)
    Sheets(1).Copy after:=Sheets(ActiveWorkbook.Sheets.Count)
   
    'Remove Buttons
    Dim I As Long
    Dim xOLE As Object
    ActiveSheet.Buttons.Delete
    For Each xOLE In ActiveSheet.OLEObjects
        If TypeName(xOLE.Object) = "CommandButton" Then
            xOLE.Delete
        End If
    Next
  
    Dim n As Integer
    Dim shtName As String
    Dim dtToday As Date
    Dim sMonth As String
    
    'MsgBox (Year(Date) & Month(Date) & Day(Date))
    'shtName = "List_" & Year(Date) & Month(Date) & Day(Date)
    dtToday = Date
    sMonth = Month(dtToday)
    If Len(sMonth) = 1 Then
        sMonth = "0" & sMonth
    End If
    'shtName = "List_" & Year(dtToday) & format(dtToday, "mm") & format(dtToday, "dd")
    shtName = "List_" & Year(dtToday) & sMonth & format(dtToday, "dd")
    
    
    'Format(Now, "yyyy/mm/dd/hh/mm/ss")
    'dtToday = Now
    'shtName = "List_" & Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
    'shtName = "List_" & Year(dtToday) & Month(dtToday) & Day(dtToday) & Hour(dtToday) & Minute(dtToday) & Second(dtToday)
    'shtName = "List_" & Year(dtToday) & format(dtToday, "mm") & Day(dtToday) & Hour(dtToday) & Minute(dtToday) & Second(dtToday)
    
    
    Do While (shCheck(shtName))
        shtName = shtName & " (2)"
        'shtName = Replace(shtName, "_", "")
    Loop
    'Sheets(2).Name = shtName
    ActiveSheet.Name = shtName
End Sub

' 해당시트가 있으면 True를, 그렇지 않으면 False 를 반환합니다
Private Function shCheck(shName$) As Boolean
   On Error GoTo ec1
   If CBool(Len(Sheets(shName$).Name)) Then shCheck = True
   Exit Function
ec1:
   shCheck = False
End Function

Private Sub addRow()
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

Private Sub addFilter()
    Range("A2:D2").Select
    Selection.AutoFilter
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    Range("B3").Select
    ActiveWindow.FreezePanes = True
    
    'Range("A1").Select
End Sub

Private Sub setRowCnt(ByVal searchCnt As Long, ByVal dblFileTotalSize As Double)
    'MsgBox "searchCnt = " & searchCnt
    Dim rowCnt As Long
    rowCnt = Range("a3", Range("a2").End(xlDown)).Rows.Count
    rowCnt = rowCnt - searchCnt
    
    Cells(1, 1) = "Number of Working Games"
    Cells(1, 2) = rowCnt
    Cells(1, 3) = "Excluded"
    Cells(1, 4) = searchCnt
    Cells(1, 5) = "Total Size"

    If (dblFileTotalSize > 1000000000) Then
        Cells(1, 6) = format(Round(dblFileTotalSize / 1000000000, 0), "#,#") & " GB" 'Format(n, "#,#")
    Else
        Cells(1, 6) = dblFileTotalSize
    End If
    
    Range("A1").Select
    Selection.HorizontalAlignment = xlCenter
    Range("C1").Select
    Selection.HorizontalAlignment = xlCenter
    Columns("E:E").EntireColumn.AutoFit
    Range("E1").Select
    Selection.HorizontalAlignment = xlCenter
    Columns("F:F").EntireColumn.AutoFit
    Range("F1").Select
    Selection.Style = "Comma [0]"
    
End Sub

listFiles_v4_20221211.xls

0.40MB

listFiles_v5_20221212_upload.xls

0.25MB

listFiles_v6_20221226.xls

0.16MB

※ 서브 디렉토리 포함(기존에 됐었던 것 같은데, 안되네요. 필요시 다음 링크 참조)

[vba] 하위폴더 내의 모든 파일 정보 가져오기 :: 개발하는 디자이너의 DIY 일상 (tistory.com)

[vba] 하위폴더 내의 모든 파일 정보 가져오기