Tạo cây thư mục với VBA

Hướng dẫn: Chạy thủ tục GetDirTrees

Sub GetDirTrees()
    Dim objFso As FileSystemObject
    Dim fileExplorer As FileDialog
    Dim strRootFolder As String
    ' Count of folder
    Dim intFolder As Integer
    ' Count of file
    Dim intFile As Integer

    Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
    ' Cho phép chọn một hoặc nhiều folder
'    fileExplorer.AllowMultiSelect = False

    With fileExplorer
        If .Show = -1 Then
            strRootFolder = .SelectedItems.Item(1)
        Else
            MsgBox "Bạn chưa chọn folder", , "AZ Edu"
            ' Khi chưa chọn folder biến strRootFolder mặc định là vbNullString
        End If
    End With
    Set fileExplorer = Nothing

    If strRootFolder = "" Then Exit Sub
 
    Set objFso = New FileSystemObject
    Call GetDir(objFso.GetFolder(strRootFolder), 0, 0, intFolder, intFile)
    Set objFso = Nothing
End Sub

Lưu ý: Cần Add thêm Windows Scrip Host Object Model để sử dụng cho objFso

Thủ tục GetDir

Private g_intMaxCol As Integer

Private Sub GetDir(ByVal objFolder As Folder, _
                   ByRef intRow As Integer, _
                   ByVal intCol As Integer, _
                   ByRef intFolder As Integer, _
                   ByRef intFile As Integer)

    Dim obbjSubFilder As Folder
    Dim objFile As File
    Dim intCol2 As Integer

    intFolder = intFolder + 1
    intRow = intRow + 1
    intCol2 = 1

    intCol = intCol + 1
    Cells(intRow, intCol).Value = "[" & objFolder.Name & "]"

    If g_intMaxCol < intCol Then g_intMaxCol = intCol

    For Each objSubFolder In objFolder.SubFolders
        Call GetDir(objSubFolder, intRow, intCol, intFolder, intFile)
    Next ' objSubFolder

    intCol2 = intCol
    intCol = intCol + 1
    intFile2 = intFile

    For Each objFile In objFolder.Files
        intFile = intFile + 1
        intRow = intRow + 1
        intCol3 = 1
        Do While intCol3 < intCol2
            intCol3 = intCol3 + 1
        Loop

        With objFile
            Cells(intRow, intCol).Value = .Name
        End With
    Next ' objFile

    Set objFolder = Nothing
End Sub

Code đã được giản lược từ https://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html

Download file GetDirTrees.xlsm

Đăng ký ngay Khóa học VBA Cơ bản đến Nâng cao để Ứng dụng hiệu quả Macro & VBA trong nâng cao hiệu xuất công việc