ต้องการ List รายชื่อ File และ Folder รวมทั้งใน Sub Folder คร

[kraikrai]

รบกวนขอความช่วยเหลือในการเขียน Code VBA ครับ คือว่าต้องการ List รายชื่อ File ใน Folder ที่กำหนด รวมทั้ง File ที่อยู่ใน Folder ย่อยด้วย ได้ Code มาจาก Internet และมาลองปรับใช้ แต่ไม่ทราบต้องแก้ไข Code นี้อย่างไรครับ

Code: Select all

Sub ListFileInFolder()
Range("B3").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Clear

Range("B3").Select
Directory = [B1] & "\"
r = 2
ListFile = Dir(Directory, vbNormal)
Do While ListFile <> ""
r = r + 1
Cells(r, 2) = ListFile
ListFile = Dir()
Loop
End Sub

ผลลัพท์ที่ต้องการตาม File ที่แนบมานี้ครับ ขอบคุณล่วงหน้าครับ

[snasui]

ลองดู Code ตามด้านล่างครับ

Code: Select all

Dim r As Long

Sub main()
    
    With Sheets(1).Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    
    With Sheets(1)
        .Range("A3").Value = "Folder Path:"
        .Range("B3").Value = "Folder Name:"
        .Range("C3").Value = "Size:"
        .Range("D3").Value = "Subfolders:"
        .Range("E3").Value = "Files:"
        .Range("F3").Value = "File Names:"
        .Range("A3:G3").Font.Bold = True
    End With
    ' and include subfolders (true/false)
    ListFolders "D:\Knowledge Warehouse\Excel", True
    Columns("A:F").AutoFit
End Sub


Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    DoEvents
    Application.DisplayAlerts = False
    
    Dim fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    
    Set fso = New Scripting.FileSystemObject
    Set SourceFolder = fso.GetFolder(SourceFolderName)
    
    On Error Resume Next
    
    r = Range("F65536").End(xlUp).Row + 1
    
    With Sheets(1)
        .Cells(r, 1).Value = SourceFolder.Path
        .Cells(r, 2).Value = SourceFolder.Name
        .Cells(r, 3).Value = SourceFolder.Size
        .Cells(r, 4).Value = SourceFolder.SubFolders.Count
        .Cells(r, 5).Value = SourceFolder.Files.Count
    End With
    
    Findfiles (SourceFolder.Path)
    
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If
      
    Set SourceFolder = Nothing
    Set fso = Nothing

End Sub

Sub Findfiles(d As String)
    Dim fname As String
    
    fname = Dir(d & "\*.*")
    Do While fname <> ""
        Sheets(1).Cells(r, 6).Value = fname
        r = r + 1
        fname = Dir
    Loop
    
End Sub

ปรับปรุงจาก http://fracta.net/fracta/index.php/foru ... -subfolder โดยจะต้อง Add Reference ที่ชื่อว่า Microsoft Scripting Runtine โดยเข้าเมนู Tools > References

[kraikrai]

ขอบคุณครับ เดี๋ยวจะไปลองใช้ในที่ทำงานพรุ่งนี้ ได้ผลยังไงแล้วจะแจ้งให้ทราบครับ ขอบคุณครับ

[kraikrai]

ใช้งานได้แล้วครับ แม้จะยังไม่ตรงกับผลลัพท์ที่ต้องการ แต่จะลองศึกษา Code นี้ดูครับ
เพราะจริงๆ ต้องการทำ Macro สำหรับ Backup ข้อมูลทุกวัน โดยมีเครื่อง A กับ เครื่อง B
เมื่อทำงานในเครื่อง A เสร็จ สิ้นวันก็กดปุ่ม Macro ที่สร้างไว้ และ Copy File / Folder
เฉพาะที่เพิ่มขึ้น หรือปรับปรุงใหม่ไปไว้ในเครื่อง B นะครับ ขอบคุณครับ