Làm thế nào liệt kê danh mục folder trong 1 folder! (1 người xem)

  • Thread starter Thread starter ThuNghi
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

ThuNghi

Hãy cho rồi sẽ nhận!
Thành viên đã mất
Tham gia
16/8/06
Bài viết
3,808
Được thích
4,449
Làm thế nào liệt kê danh mục folder trong 1 folder!
Tôi muốn làm 1 code liệt kê các folder có trong 1 folder mà chưa làm được.
Ví dụ: Tôi có folder Soft (D:\Soft), tôi muốn liệt kê các folder có trong D:\soft và gắn vào bảng tính.
Tôi thử dùng code sau nhưng khi thay myPath = "D:\soft" thì không được.
Nhờ các bạn HD. Xin cám ơn!

PHP:
Option Explicit
Private Sub Form_Load01()
Dim MyFile, myPath, MyName, i
    myPath = "D:\" ' Gan MyPath '"
    MyName = Dir(myPath, vbDirectory) ' Gan MyName= ten thu muc dau tien trong MyPath'
    i = 1
    Do While MyName <> "" ' Bat dau vong lap'
      'Bo qua cac thu muc hien tai va thu muc xung quanh'
        If MyName <> "." And MyName <> ".." Then
          ' Su dung su so sanh phan theo Bit de chac chac MyName la mot thu muc'
            If (GetAttr(myPath & MyName) And vbDirectory) = vbDirectory Then
              Sheet3.Cells(i, 1) = MyName
              i = i + 1
            End If
       End If
       MyName = Dir ' Nhay den thu muc ke tiep'
    Loop
End Sub
 
Chỉnh sửa lần cuối bởi điều hành viên:
Đoạn code sau nó sẽ liệt kê hết tất cả các file trong folder, không biết có thể giúp gì cho bạn không.

Mã:
Sub HyperlinksToDirectory()
    Dim stDir As String
    Dim stFile As String
    Dim R As Range
    Set R = ActiveCell
    stDir = InputBox("Directory?", , Default:=CurDir())
    stFile = Dir(stDir & "\*.*")
    Do Until stFile = ""
        R.Hyperlinks.Add R, stDir & "\" & stFile, , , stFile
        Set R = R.Offset(1)
        stFile = Dir()
    Loop
    R.CurrentRegion.Sort key1:=R, order1:=xlAscending, header:=xlNo
End Sub
Bạn tham khảo file đính kèm nhe
Thân
 

File đính kèm

Upvote 0
Đoạn code sau nó sẽ liệt kê hết tất cả các file trong folder, không biết có thể giúp gì cho bạn không.

Bạn tham khảo file đính kèm nhe
Thân
Cám ơn bạn nhiều, file thì tôi tham khảo file của Thầy Voda rồi. Vấn đề là liệt kê các thư mục con trong 1 thư mục mẹ (cho trước) thôi.
 
Upvote 0
liệt kế danh sách file

1> Lấy danh sách tên các file có trong thư mục hiện hành (thư mục chứa file Excel mà ta đang chạy)
PHP:
Option Explicit
Sub SeachFiles1()
  Dim i As Long, MyDir As String
  Range("A1").CurrentRegion.Offset(1).ClearContents
  MyDir = ThisWorkbook.Path
  With Application.FileSearch
    '.SearchSubFolders = True    '<--- Tim ca trong thu muc con
    .LookIn = MyDir              '<--- Tim trong thu muc này
    .Filename = "*.*"            '<--- Kieu file can tìm
    If .Execute() > 0 Then
      For i = 1 To .FoundFiles.Count
        [A65536].End(xlUp).Offset(1) = Replace(.FoundFiles(i), MyDir & "\", "")
      Next i
    End If
    MsgBox .FoundFiles.Count & " files found."
  End With
End Sub

2> Lấy danh sách tên file trong 1 thư mục nào đó tùy ta chọn
PHP:
Option Explicit
Sub SeachFiles2()
  Dim i As Long
  Range("A1").CurrentRegion.Offset(1).ClearContents
  With Application.FileDialog(3)
    .AllowMultiSelect = True: .Show
    For i = 1 To .SelectedItems.Count
      [A65536].End(xlUp).Offset(1) = .SelectedItems(i)
    Next i
    MsgBox .SelectedItems.Count & " files Selected "
  End With

End Sub

Đoạn code trên em tham khảo của Anh Tuấn
link
http://www.giaiphapexcel.com/forum/showthread.php?t=17212
 
Upvote 0
Nếu không cần liệt kê các Sub Folder thì chỉ cần thế này là đủ:
PHP:
Sub GetFolderlist()
  Dim FolObj, Item, i As Long
  With Application.FileDialog(4)
    .Show
    Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(.SelectedItems(1))
  End With
  For Each Item In FolObj.SubFolders
    i = i + 1: Cells(i , 1) = Item.Name
  Next
End Sub
 
Upvote 0
Nếu không cần liệt kê các Sub Folder thì chỉ cần thế này là đủ:
PHP:
Sub GetFolderlist()
  Dim FolObj, Item, i As Long
  With Application.FileDialog(4)
    .Show
    Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(.SelectedItems(1))
  End With
  For Each Item In FolObj.SubFolders
    i = i + 1: Cells(i , 1) = Item.Name
  Next
End Sub
Rất cám ơn Bác, và RollOver.
Bác ndu có thể triển khai thêm, có thể lấy thư mục con theo từng cấp.
Ví dụ:
Thư mục mẹ: D:\Soft
Thư mục con 1: D:\Soft\Excel
Thư mục con 1: D:\Soft\Word
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Nếu chọn cấp 1 sẽ list
- Thư mục con 1: D:\Soft\Excel
- Thư mục con 1: D:\Soft\Word
Nếu chọn cấp 2 từ D:\Soft\Excel sẽ list
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Rất cám ơn 2 Bác.
 
Upvote 0
Rất cám ơn Bác, và RollOver.
Bác ndu có thể triển khai thêm, có thể lấy thư mục con theo từng cấp.
Ví dụ:
Thư mục mẹ: D:\Soft
Thư mục con 1: D:\Soft\Excel
Thư mục con 1: D:\Soft\Word
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Nếu chọn cấp 1 sẽ list
- Thư mục con 1: D:\Soft\Excel
- Thư mục con 1: D:\Soft\Word
Nếu chọn cấp 2 từ D:\Soft\Excel sẽ list
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Rất cám ơn 2 Bác.
ThuNghi xem file của Rollover79... Nó làm được yêu cầu của bạn đấy
Còn tôi thì.. đang nghiên cứu ---> Search trên google có rất nhiều nhưng không hiểu lắm (chưa đủ công lực) nên chưa cải tiến nổi
File trên mạng cái nào code cũng dài nhằng... theo tôi, code của Rollover79 là cực ngắn rồi đấy! ThuNghi xem code và cải tiến theo ý mình nhé!
 
Upvote 0
Rất cám ơn Bác, và RollOver.
Bác ndu có thể triển khai thêm, có thể lấy thư mục con theo từng cấp.
Ví dụ:
Thư mục mẹ: D:\Soft
Thư mục con 1: D:\Soft\Excel
Thư mục con 1: D:\Soft\Word
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Nếu chọn cấp 1 sẽ list
- Thư mục con 1: D:\Soft\Excel
- Thư mục con 1: D:\Soft\Word
Nếu chọn cấp 2 từ D:\Soft\Excel sẽ list
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Rất cám ơn 2 Bác.

Tìm trên web được trang này This add-in creates a listing of a directory and all its sub-directories rất chuyên nghiệp,có cả code.
Rất tiếc là chưa đủ trình độ để hiểu. Gởi các bạn nghiêu cứu.
DirPath.jpg


Installation Instructions The downloadable zip file contains an exe installation and setup file. Unzip the file to any directory and run the program DirTreeSetup.exe. This will install XLA file in to the folder you specify. Then, open Excel with a blank workbook open, go to the Tools menu and choose Add-Ins. In that dialog, click Browse and navigate to the folder in which you installed the XLA file and open the XLA. Then click OK in the Add-Ins dialog. When the add-in is loaded, it will create an item on your Tools menu.
You are free to examine and modify the code. The project is password protected to prevent it from opening all its windows at startup in the VBA Editor. The password for the project is 'a'.
 
Upvote 0
Rất cám ơn Bác, và RollOver.
Bác ndu có thể triển khai thêm, có thể lấy thư mục con theo từng cấp.
Ví dụ:
Thư mục mẹ: D:\Soft
Thư mục con 1: D:\Soft\Excel
Thư mục con 1: D:\Soft\Word
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Nếu chọn cấp 1 sẽ list
- Thư mục con 1: D:\Soft\Excel
- Thư mục con 1: D:\Soft\Word
Nếu chọn cấp 2 từ D:\Soft\Excel sẽ list
Thư mục con 2: D:\Soft\Excel10
Thư mục con 2: D:\Soft\Excel11
Thư mục con 2: D:\Soft\Excel12
Rất cám ơn 2 Bác.
Yêu cầu này của bác ThuNghi có vẻ khác với bài toán của tôi, ở file kia là liết kê ra tất cả các thư mục con mọi cấp của 1 thư mục, với yêu cầu này thì code dùng thuật toán đệ quy có lẽ là tối ưu rồi. Còn ở đây hình như bác ThuNghi đang muốn liệt kê các thư mục con tại 1 cấp cụ thể nào đó thì phải. Nếu đúng thì bác thử dùng đoạn code này xem sao(Mượn code của NDU để sửa lại chút)
Mã:
Sub GetFolderlist(Optional Depth As Integer = 1)
  Dim FolObj, Item, i As Long
  With Application.FileDialog(4)
    .Show
    Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(.SelectedItems(1))
  End With
  Dim arr1() As String
  Dim arr2() As String
  ReDim arr1(1 To 1)
  arr1(1) = FolObj.Path
  Do While Depth >= 1
    ReDim arr2(0)
    For i = LBound(arr1) To UBound(arr1)
        Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(arr1(i))
        For Each Item In FolObj.SubFolders
            If LBound(arr2) = 0 Then
                ReDim arr2(1 To 1)
            Else
                ReDim Preserve arr2(1 To UBound(arr2) + 1)
            End If
            arr2(UBound(arr2)) = Item.Path
        Next
    Next
    Depth = Depth - 1
    If LBound(arr2) = 0 Then Exit Do
    ReDim arr1(1 To UBound(arr2))
    For i = LBound(arr1) To UBound(arr1)
        arr1(i) = arr2(i)
    Next
  Loop
  If UBound(arr2) > 0 Then
    For i = LBound(arr2) To UBound(arr2)
        Cells(i, 1) = arr2(i)
    Next
  End If
End Sub
 
Upvote 0
Yêu cầu này của bác ThuNghi có vẻ khác với bài toán của tôi, ở file kia là liết kê ra tất cả các thư mục con mọi cấp của 1 thư mục, với yêu cầu này thì code dùng thuật toán đệ quy có lẽ là tối ưu rồi. Còn ở đây hình như bác ThuNghi đang muốn liệt kê các thư mục con tại 1 cấp cụ thể nào đó thì phải. Nếu đúng thì bác thử dùng đoạn code này xem sao(Mượn code của NDU để sửa lại chút)
Mã:
Sub GetFolderlist(Optional Depth As Integer = 1)
  Dim FolObj, Item, i As Long
  With Application.FileDialog(4)
    .Show
    Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(.SelectedItems(1))
  End With
  Dim arr1() As String
  Dim arr2() As String
  ReDim arr1(1 To 1)
  arr1(1) = FolObj.Path
  Do While Depth >= 1
    ReDim arr2(0)
    For i = LBound(arr1) To UBound(arr1)
        Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(arr1(i))
        For Each Item In FolObj.SubFolders
            If LBound(arr2) = 0 Then
                ReDim arr2(1 To 1)
            Else
                ReDim Preserve arr2(1 To UBound(arr2) + 1)
            End If
            arr2(UBound(arr2)) = Item.Path
        Next
    Next
    Depth = Depth - 1
    If LBound(arr2) = 0 Then Exit Do
    ReDim arr1(1 To UBound(arr2))
    For i = LBound(arr1) To UBound(arr1)
        arr1(i) = arr2(i)
    Next
  Loop
  If UBound(arr2) > 0 Then
    For i = LBound(arr2) To UBound(arr2)
        Cells(i, 1) = arr2(i)
    Next
  End If
End Sub
Code hơi bị ngon à nha!
Vậy ThuNghi chỉ cần thêm 1 đoạn code nhỏ nữa là.. ăn tiền:
PHP:
Sub Main()
  GetFolderlist (Application.InputBox("Lay list folder cap may?", Type:=1))
End Sub
Với Rollover79:
- Optional Depth mặc định là cấp 1 tôi thấy không hay lắm
- Bạn có thể chỉnh code thế nào để khi người ta không gõ Optional Depth vào thì đồng nghĩa là lấy toàn bộ các cấp
 
Lần chỉnh sửa cuối:
Upvote 0
Với Rollover79:
- Optional Depth mặc định là cấp 1 tôi thấy không hay lắm
- Bạn có thể chỉnh code thế nào để khi người ta không gõ Optional Depth vào thì đồng nghĩa là lấy toàn bộ các cấp
Vậy chắc không còn cách nào khác lại phải đệ quy thôi, code sửa lại 1 chút.
Mã:
Sub GetFolderlist(strPath As String, Optional ByRef iRow As Long = 1, Optional Depth)
  Dim FolObj, Item, i As Long
  Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
  If IsMissing(Depth) Or Not IsNumeric(Depth) Then
    For Each Item In FolObj.Subfolders
        Cells(iRow, 1) = Item.Path
        iRow = iRow + 1
        If CreateObject("Scripting.FileSystemObject").GetFolder(Item.Path).Subfolders.Count > 0 Then
            Call GetFolderlist(Item.Path, iRow)
        End If
    Next
  Else
    Dim arr1() As String
    Dim arr2() As String
    ReDim arr1(1 To 1)
    arr1(1) = FolObj.Path
    Do While Depth >= 1
      ReDim arr2(0)
      For i = LBound(arr1) To UBound(arr1)
          Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(arr1(i))
          For Each Item In FolObj.Subfolders
              If LBound(arr2) = 0 Then
                  ReDim arr2(1 To 1)
              Else
                  ReDim Preserve arr2(1 To UBound(arr2) + 1)
              End If
              arr2(UBound(arr2)) = Item.Path
          Next
      Next
      Depth = Depth - 1
      If LBound(arr2) = 0 Then Exit Do
      ReDim arr1(1 To UBound(arr2))
      For i = LBound(arr1) To UBound(arr1)
          arr1(i) = arr2(i)
      Next
    Loop
    If UBound(arr2) > 0 Then
      For i = LBound(arr2) To UBound(arr2)
          Cells(i, 1) = arr2(i)
      Next
    End If
End If
End Sub
 
Upvote 0
Đại ca ơi, chạy nó thế nào... Tôi loay hoay nảy giờ vẫn chưa được (cho file đính kèm với)
Dùng sub này để test, dưới đây là lấy Dept=2, nếu muốn list tất thì không truyền Depth vào nữa.
Mã:
Sub test()
  With Application.FileDialog(4)
    .Show
    Call GetFolderlist(.SelectedItems(1), Depth:=2)
  End With
End Sub
 
Upvote 0
Dùng sub này để test, dưới đây là lấy Dept=2, nếu muốn list tất thì không truyền Depth vào nữa.
Mã:
Sub test()
  With Application.FileDialog(4)
    .Show
    Call GetFolderlist(.SelectedItems(1), Depth:=2)
  End With
End Sub
Ôi... trời ơi!
Xin thề (có God) là nãy giờ tôi đã làm như thế (có lý nào tôi lại không biết đoạn code nhỏ này) ---> Ấy vậy mà nảy giờ nó cứ trơ trơ (báo lổi tùm lum) ---> Còn bây giờ lại chạy ngon lành!
Ẹc... Ẹc... Dã man quá đi!
------------
Hỏi thêm: Option iRow ấy để làm gì thế? Tôi thay 1, 2, 3 vào, chẳng thấy có gì khác biệt cả
 
Upvote 0
Hỏi thêm: Option iRow ấy để làm gì thế? Tôi thay 1, 2, 3 vào, chẳng thấy có gì khác biệt cả
Ai nói là ko có gì khác biệt chứ, nó chính là dòng đầu tiên dùng để hiển thị kết quả đấy. Nhưng công nhận là biến này hiểm thật, mà thiếu nó thì không xong đâu. Để ý nhé, tham số này phải khải báo là ByRef, chứ khai báo là ByVal là tèo ngay.
 
Upvote 0
Ai nói là ko có gì khác biệt chứ, nó chính là dòng đầu tiên dùng để hiển thị kết quả đấy. Nhưng công nhận là biến này hiểm thật, mà thiếu nó thì không xong đâu. Để ý nhé, tham số này phải khải báo là ByRef, chứ khai báo là ByVal là tèo ngay.
Vâng, Thưa đại ca! Tôi nhìn code cũng đoán được iRow là chỉ số dòng! Có điều hơi bất hợp lý:
- Nếu tôi ghi đầy đủ vào sub Main:
PHP:
Sub Main()
  With Application.FileDialog(4)
    .Show
    Call GetFolderlist(.SelectedItems(1), iRow:=3, Depth:=2)
  End With
End Sub
Thì cái iRow này lại chẳng tác dụng gì... có ghi iRow bằng mấy thì nó cũng xuất dử liệu tại cell A1
Trừ phi tôi bỏ mất biến Depth thì iRow mới có tác dụng
Phi lý, đúng không?
???
-------------
Tôi nghĩ có lẽ phải sửa chổ này:
PHP:
If UBound(arr2) > 0 Then
      For i = LBound(arr2) To UBound(arr2)
          Cells(i , 1) = arr2(i)
      Next
End If
thành:
PHP:
If UBound(arr2) > 0 Then
      For i = LBound(arr2) To UBound(arr2)
          Cells(i - 1 + iRow, 1) = arr2(i)
      Next
End If
thì hợp lý hơn!
Bạn Rollover79 thấy sao?
 
Lần chỉnh sửa cuối:
Upvote 0
Các thủ tục này cải biên từ DeQuy_ListFolder.xls của rollover79.
Có thể chạy từ Sub LoadAllFolder hoặc LoadAllFolder1.
Sub LoadAllFolder: chọn thự mục từ hộp thoại Browse For Folder.
Sub LoadAllFolder1: nhập đường dẫn, thư mục vào InputBox Path.
Danh sách thư mục sẽ ghi vào cột thứ c, ô đầu tiên ở dòng r của sheet active.
Mã:
r = 1
c = 2
Cells(1, c).EntireColumn.ClearContents
Các dòng lệnh trên sẽ xóa cột 2 (c=2) và ghi vào ô đầu tiên là B1 (r=1, c=2)

Nhập số cấp thư mục vào InputBox Path Id (biến nCap) với quy định:
- nCap < 0: liệt kê tất cả các cấp
- nCap = 0: chỉ ghi thư mục chọn.
- nCap > 0: liệt kê đến thư mục cấp nCap.


Mã:
Option Explicit
Dim objFSO As New FileSystemObject

Private Sub LoadFolder(strPath As String, r, c, nId, nCap)
If Not objFSO.FolderExists(strPath) Then Exit Sub
Dim objFolder As Folder
If nCap < 0 Then
    Cells(r, c) = objFSO.GetFolder(strPath).Path
    r = r + 1
ElseIf nId = nCap Then
  If nId = nCap Then
    Cells(r, c) = objFSO.GetFolder(strPath).Path
    r = r + 1
  End If
End If
For Each objFolder In objFSO.GetFolder(strPath).SubFolders
  Call LoadFolder(objFolder.Path, r, c, nId + 1, nCap)
Next
End Sub

Public Sub LoadAllFolder()
Dim sPath As String, nCap As Long, nId As Long, r As Long, c As Long
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0)
On Error Resume Next
sPath = ShellApp.Self.Path
On Error GoTo 0
Set ShellApp = Nothing
If Not objFSO.FolderExists(sPath) Then Exit Sub
nCap = Application.InputBox("Chon cap thu muc:", "Path Id", 1, , , , , 1)
r = 1
c = 2
Cells(1, c).EntireColumn.ClearContents
Call LoadFolder(sPath, r, c, nId, nCap)
End Sub

Public Sub LoadAllFolder1()
Dim sPath As String, nCap As Long, nId As Long, r As Long, c As Long
sPath = Application.InputBox("Nhap duong dan (ex: D:\SOFT ):", "Path", , , , , , 2)
'sPath = "D:\A"
If Not objFSO.FolderExists(sPath) Then Exit Sub
nCap = Application.InputBox("Chon cap thu muc:", "Path Id", 1, , , , , 1)
r = 1
c = 2
Cells(1, c).EntireColumn.ClearContents
Call LoadFolder(sPath, r, c, nId, nCap)
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Vâng, Thưa đại ca! Tôi nhìn code cũng đoán được iRow là chỉ số dòng! Có điều hơi bất hợp lý:
- Nếu tôi ghi đầy đủ vào sub Main:
PHP:
Sub Main()
  With Application.FileDialog(4)
    .Show
    Call GetFolderlist(.SelectedItems(1), iRow:=3, Depth:=2)
  End With
End Sub
Thì cái iRow này lại chẳng tác dụng gì... có ghi iRow bằng mấy thì nó cũng xuất dử liệu tại cell A1
Trừ phi tôi bỏ mất biến Depth thì iRow mới có tác dụng
Phi lý, đúng không?
???
-------------
Tôi nghĩ có lẽ phải sửa chổ này:
PHP:
If UBound(arr2) > 0 Then
      For i = LBound(arr2) To UBound(arr2)
          Cells(i , 1) = arr2(i)
      Next
End If
thành:
PHP:
If UBound(arr2) > 0 Then
      For i = LBound(arr2) To UBound(arr2)
          Cells(i - 1 + iRow, 1) = arr2(i)
      Next
End If
thì hợp lý hơn!
Bạn Rollover79 thấy sao?
Ý tôi thực ra không phải dùng iRow để xác định dòng bắt đầu xuất kết quả, mà khi dùng đệ quy thì bắt buộc phải có biến này mới xong. Nên với trường hợp có tham số Depth vào thì làm gì còn đệ quy nữa nên biến này cũng không cần thiết là đương nhiên rồi.
 
Upvote 0
Xin lỗi, cho tham gia với. Mình thấy code của các bạn dài và tốc độ hơi mệt. Các bạn xem đây là file mình cải biên từ Help của Excel. Gọn gàng và ấn tượng về tốc độ.
 

File đính kèm

Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom