Viết code tạo thư mục và sheet tương ứng với thư mục.

thanhnhanubnd · 11/5/09

Mình có 01 yêu cầu, xin nhờ các bạn chỉ giúp :

Mình đã có 01 file excel : D:\BKAV\book1.xls, trong đó có 03 sheet1,2,3.
Tạo thư mục : Làm 01 nút tạo thư mục, khi nhấn vào sẽ tạo thư mục trong đường dẫn trên. Ví dụ, khi nhấn vào :
Mgs : Hay nhập tê thư mục .
Nhập tên : "AAA" nhấn ok.
sẽ cho kết quả : D:\BKAV\AAA. Tương tư : D:\BKAV\AAA.
- Kiểm tra nếu thư mục đã có thì không cho nhập trùng.
Tạo sheet tương ứng với thư mục :

- xóa các sheet cũ.
- Tương ứng với 01 thư mục trong thư mục D:\BKAV sẽ tạo 01 sheet mang tên thư mục và đường dẫn đến thư mục này sẽ xuất hiện trong ô (1,1).Ví dụ :
sheet 1 = AAA, đường dẫn : D:\AAA\ sẽ xuất hiện trong ô A1.
sheet 2 = BBB, đường dẫn : D:\BBB\ sẽ xuất hiện trong ô A1.

Thank.

levanduyet · 11/5/09

thanhnhanubnd đã viết:
Mình có 01 yêu cầu, xin nhờ các bạn chỉ giúp :

Mình đã có 01 file excel : D:\BKAV\book1.xls, trong đó có 03 sheet1,2,3.

Tạo thư mục : Làm 01 nút tạo thư mục, khi nhấn vào sẽ tạo thư mục trong đường dẫn trên. Ví dụ, khi nhấn vào :
Mgs : Hay nhập tê thư mục .
Nhập tên : "AAA" nhấn ok.
sẽ cho kết quả : D:\BKAV\AAA. Tương tư : D:\BKAV\AAA.
- Kiểm tra nếu thư mục đã có thì không cho nhập trùng.

Tạo sheet tương ứng với thư mục :

- xóa các sheet cũ.
- Tương ứng với 01 thư mục trong thư mục D:\BKAV sẽ tạo 01 sheet mang tên thư mục và đường dẫn đến thư mục này sẽ xuất hiện trong ô (1,1).Ví dụ :
sheet 1 = AAA, đường dẫn : D:\AAA\ sẽ xuất hiện trong ô A1.
sheet 2 = BBB, đường dẫn : D:\BBB\ sẽ xuất hiện trong ô A1.

Thank.

Tạo thư mục:
Bạn có thể tham khảo code sau (Nguồn)

Mã:

Sub CreateFolders(sFolderPath As String)
Dim sSubFolder As String
Dim sBaseFolder As String
Dim sTemp As String

ArryDir = Split(sFolderPath, "\")

For i = 0 To UBound(ArryDir) - 2
    sBaseFolder = sBaseFolder & ArryDir(i)
    sSubFolder = ArryDir(i + 1)
    'Make sure the base folder is ready to have a sub folder
    'tacked on to the end
    If Right(sBaseFolder, 1) "\" Then
        sBaseFolder = sBaseFolder & "\"
    End If

    'Make sure base folder exists
    If Len(Dir(sBaseFolder, vbDirectory)) > 0 Then
        'Replace illegal characters with an underscore
        sTemp = CleanFolderName(sSubFolder)
        'See if already exists: Thanks Dave W.
        If Len(Dir(sBaseFolder & sTemp, vbDirectory)) = 0 Then
            'Use MkDir to create the folder
            MkDir sBaseFolder & sTemp
        End If
    End If
Next
End Sub

Tạo worksheet:
Nguồn.

LVD

thanhnhanubnd · 12/5/09

Code bạn chạy ko được rồi. Nguồn tạo worksheet không được,

levanduyet · 12/5/09

To: thanhnhanubnd,
Tôi chỉ đưa ra nguồn để bạn tham khảo code. Còn nếu nó báo lỗi, bạn phải debug xem nó báo lỗi lý do gì? để còn có thế sửa code.
Bạn nên upload luôn code lên và nhớ để trong tag CODE.

LVD

thanhnhanubnd · 12/5/09

Nhờ bạn viết dùm đoạn code :
1. Liệt kê tất cả thư mục con trong một thư mục chỉ định.
2. Tương ứng với 01 thư mục tạo 01 sheet mang tên thư mục đó.
Ví dụ :
D:\BKAV\AAA ---> sheet AAA
D:\BKAV\BBB ---> sheet BBB
.......

XuanThanh · 12/5/09

thanhnhanubnd đã viết:
Nhờ bạn viết dùm đoạn code :
1. Liệt kê tất cả thư mục con trong một thư mục chỉ định.
2. Tương ứng với 01 thư mục tạo 01 sheet mang tên thư mục đó.
Ví dụ :
D:\BKAV\AAA ---> sheet AAA
D:\BKAV\BBB ---> sheet BBB
.......

Bạn xem lại Cái sheet mang tên thư mục đó nằm ở đâu? Chẳng lẽ lại nằm chơ vơ ngoài...vũ trụ khi không có một Wb nào chứa nó?
Thân

levanduyet · 12/5/09

thanhnhanubnd đã viết:
Nhờ bạn viết dùm đoạn code :
1. Liệt kê tất cả thư mục con trong một thư mục chỉ định.
2. Tương ứng với 01 thư mục tạo 01 sheet mang tên thư mục đó.
Ví dụ :
D:\BKAV\AAA ---> sheet AAA
D:\BKAV\BBB ---> sheet BBB
.......

Bạn vui lòng tham khảo links này.
Rất nhiều code.

Tôi nghĩ các bạn khác cũng cố gắng tìm kiếm trước khi đặt vấn đề.

Lê Văn Duyệt

ThuNghi · 12/5/09

levanduyet đã viết:
Bạn vui lòng tham khảo links này.
Rất nhiều code.

Tôi nghĩ các bạn khác cũng cố gắng tìm kiếm trước khi đặt vấn đề.

Lê Văn Duyệt

Anh Duyệt xem lại hộ code sau theo links có sai chỗ nào mà test không được.
Đã cài Microsoft Scripting Runtime

PHP:

Sub Ck()
     Dim strStartPath As String
    strStartPath = "D:\Tam" 'ENTER YOUR START FOLDER HERE'
    ListFolder strStartPath
     
End Sub
Sub ListFolder(sFolderPath As String)
     
    Dim FS As New FileSystemObject
    Dim FSfolder As Folder
    Dim SubFolder As Folder
    Dim i As Integer
    Set FSfolder = FS.GetFolder(sFolderPath)
     
    For Each SubFolder In FSfolder.SubFolders
        DoEvents
        i = i + 1
         'added this line'
        Cells(i, 1) = SubFolder
         'commented out this one'
         'Debug.Print subfolder'
    Next SubFolder
     
    Set FSfolder = Nothing
     
     'optional, I suppose'
     MsgBox " Total sub folders in " & sFolderPath & " : " & i
     
End Sub

Báo lỗi ở dòng này.

PHP:

Set FSfolder = FS.GetFolder(sFolderPath)

Và cũng đã sửa
strStartPath=sFolderPath
Nếu được Duyệt cho xin 1 ví dụ.
Cám ơn nhiều.

levanduyet · 12/5/09

To: Anh ThuNghi,

Anh vào cửa sổ VBE, chọn Tools ~~> References
Chọn Microsoft Scripting Runtime (thông thường C:\Windows\System32\scrrun.dll)

Như vậy anh có thể thực thi đoạn code trên rồi.

LVD

ThuNghi · 12/5/09

levanduyet đã viết:
To: Anh ThuNghi,

Anh vào cửa sổ VBE, chọn Tools ~~> References

Chọn Microsoft Scripting Runtime (thông thường C:\Windows\System32\scrrun.dll)

Như vậy anh có thể thực thi đoạn code trên rồi.

LVD

OK, rồi, thành thật xin lỗi, do nhập path sai. D: không có folder Tam.
Cám ơn nhiều.
Nhờ SMod xóa hộ.

thanhnhanubnd · 12/5/09

XuanThanh đã viết:
Bạn xem lại Cái sheet mang tên thư mục đó nằm ở đâu? Chẳng lẽ lại nằm chơ vơ ngoài...vũ trụ khi không có một Wb nào chứa nó?
Thân

* VD ta có thư mục D:\BKAV gồm 2 thư muccọn : AAA, BBB.
1.Ta tạo 1 file excel trong thư mục D:\BKAV\.
2. Ta sẽ dùng code để liệt kê các subfoder trong thư mục D:\BKAV\ ( bao nhiêu thư mục thì bấy nhiêu sheets).
3. Địa chỉ : D:\BKAV\AAA sẽ hiện thị trong ô D3 sheet AAA
Địa chỉ : D:\BKAV\BBB sẽ hiện thị trong ô D3 sheet BBB

Cái sheet mang tên thư mục nằm trong file excel mình tạo đó bạn.

Thank.

ThuNghi · 12/5/09

thanhnhanubnd đã viết:
* VD ta có thư mục D:\BKAV gồm 2 thư muccọn : AAA, BBB.
1.Ta tạo 1 file excel trong thư mục D:\BKAV\.
2. Ta sẽ dùng code để liệt kê các subfoder trong thư mục D:\BKAV\ ( bao nhiêu thư mục thì bấy nhiêu sheets).
3. Địa chỉ : D:\BKAV\AAA sẽ hiện thị trong ô D3 sheet AAA
Địa chỉ : D:\BKAV\BBB sẽ hiện thị trong ô D3 sheet BBB

Cái sheet mang tên thư mục nằm trong file excel mình tạo đó bạn.

Thank.

Bạn dùng code sau, nó sẽ tự tìm thư mục và liệt kê thư mục con.
Bạn hãy run GetFolderList, sau đó DatTen

PHP:

Option Explicit
Dim FolObj As Object, MyPath As String
Dim Item As Object, i As Long
Dim Rng As Range, ShName As String, endR As Long
Sub GetFolderList()
  MyPath = ThisWorkbook.Path
  Sheet1.Select
  Range(Cells(2, 1), Cells(1000, 2)).ClearContents
  Set FolObj = CreateObject("Scripting.FileSystemObject").GetFolder(MyPath)
  For Each Item In FolObj.SubFolders
    i = i + 1: Cells(i + 1, 2) = Item.Name: Cells(i + 1, 1) = i
  Next
End Sub
Sub DatTen()
  On Error GoTo thoat
  Sheet1.Select
  MyPath = ThisWorkbook.Path
  endR = Cells(65000, 2).End(xlUp).Row
  If endR = 1 Then Exit Sub
  Set Rng = Sheet1.Range(Cells(2, 2), Cells(endR, 2))
  For i = 1 To Rng.Count
    ShName = Rng(i)
    If SheetExists(ShName) Then
        Sheets(ShName).Cells(3, 4) = MyPath & Rng(i)
    Else
    'tao sheet'
      Sheets.Add
      With ActiveSheet
        .Name = Rng(i)
        .Cells(3, 4) = MyPath & Rng(i)
      End With
    GoTo tiep
    End If
tiep:
  Sheet1.Select
  Next
thoat:
  Set Rng = Nothing
End Sub
Private Function SheetExists(ShName) As Boolean
  Dim x As Object
  On Error Resume Next
  Set x = ActiveWorkbook.Sheets(ShName)
  If Err = 0 Then SheetExists = True _
      Else SheetExists = False
End Function

levanduyet · 12/5/09

To: Anh ThuNghi,
Em nhớ là đã có làm ebook về vấn đề này:
http://www.giaiphapexcel.com/forum/showthread.php?t=12053
Các bạn tham khảo phần các thao tác chung.

Lê Văn Duyệt

thanhnhanubnd · 12/5/09

ToThu Nghi

Code của bạn mình chạy chưa đúng ý mình, nó chỉ tạo các sheet1,.... không laấy được tên thư mục làm tên sheet. Thank.

anhphuong · 13/5/09

thanhnhanubnd đã viết:
* VD ta có thư mục D:\BKAV gồm 2 thư muccọn : AAA, BBB.
1.Ta tạo 1 file excel trong thư mục D:\BKAV\.
2. Ta sẽ dùng code để liệt kê các subfoder trong thư mục D:\BKAV\ ( bao nhiêu thư mục thì bấy nhiêu sheets).
3. Địa chỉ : D:\BKAV\AAA sẽ hiện thị trong ô D3 sheet AAA
Địa chỉ : D:\BKAV\BBB sẽ hiện thị trong ô D3 sheet BBB

Cái sheet mang tên thư mục nằm trong file excel mình tạo đó bạn.

Thank.

Bạn chép đoạn code này vào sheet bất kỳ:

PHP:

Sub Ck()
    Dim strStartPath As String
    strStartPath = Cells(1, 5) 
    ListFolder strStartPath
End Sub


Sub ListFolder(sFolderPath As String)
    Dim FS As New FileSystemObject
    Dim FSfolder As Folder
    Dim SubFolder As Folder
    Dim i As Integer
    Set FSfolder = FS.GetFolder(sFolderPath)
    For Each SubFolder In FSfolder.SubFolders
        DoEvents
        i = i + 1
        Cells(i, 1) = SubFolder
        Cells(i, 2) = SubFolder.Name
    Next SubFolder
    For k = 1 To Range("B65000").End(xlUp).Row
        ThisWorkbook.Sheets.Add.Name = Cells(k, 2)
    Next
    Set FSfolder = Nothing
End Sub

Các bước thực hiện như sau :
1/ Ghi tên thư mục cần liệt kê thư mục con ( Ví dụ D:\ThanhNhan ) vào ô E5 của sheet này
2/ Run Sub Ck ==> OK

Lưu ý rằng tên sheet có độ dài vừa phải nên các thư mục con cũng phải có độ dàì hợp lý, nếu không muốn xảy ra lỗi

ThuNghi · 13/5/09

thanhnhanubnd đã viết:
ToThu Nghi

Code của bạn mình chạy chưa đúng ý mình, nó chỉ tạo các sheet1,.... không laấy được tên thư mục làm tên sheet. Thank.

PHP:

'tao sheet'
      Sheets.Add
      With ActiveSheet
        .Name = Rng(i)
        .Cells(3, 4) = MyPath & Rng(i)
      End With

Cái đọan này là tạo tên sh mà.
Có 1 thắc mắc nhờ các bạn xem hộ.
1/ Khi tạo HyperLink mà sao nhấn vào nó không được.

PHP:

Sub GetFileName()
On Error Resume Next
Application.ScreenUpdating = False
Sheet2.Select
Range(Cells(2, 1), Cells(1000, 5)).ClearContents
MyPath = ThisWorkbook.Path
With Sheet1
  endR = .Cells(65000, 2).End(xlUp).Row
  If endR = 1 Then
    MsgBox "Ban chua chon GetFolder"
    Exit Sub
  End If
  Set Rng = .Range(.Cells(2, 2), .Cells(endR, 2))
End With
j = 2
For i = 1 To Rng.Count
  FolderName = Rng(i)
 fName = Dir(MyPath & "\" & FolderName & "\" & "*.*")
  While fName <> ""
    Cells(j, 1) = CStr(j - 1)
    Cells(j, 2) = FolderName
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(j, 3), Address:=MyPath & "\" & fName, TextToDisplay:=fName
    fName = Dir
    j = j + 1
  Wend
Next
Application.ScreenUpdating = True
End Sub

2/ Muốn thêm thuộc tính file (*.doc, *.xls, *.pdf...) thì làm sao.
Đính kèm file, các bạn xem giúp. Chép vào 1 thư mục nào mà có thư mục con là OK.
Cám ơn anhphuong, OK rồi, chỉ thiếu một dấu "/". Của bác là " "

anhphuong · 13/5/09

ThuNghi tạo Hperlink mà thiếu thư mục chứ nó thì làm sao mà link đượic
Sai ở dòng lệnh này

PHP:

ActiveSheet.Hyperlinks.Add Anchor:=Cells(j, 3), Address:=MyPath & "\"  & fName, TextToDisplay:=fName

Phải sửa lại là :

PHP:

ActiveSheet.Hyperlinks.Add Anchor:=Cells(j, 3), Address:=MyPath & "\" & FolderName & "\ "  &  fName, TextToDisplay:=fName

Thân

anhphuong · 13/5/09

Thu Nghi muốn thêm thuộc tính file thì sửa như sau :

PHP:

....
For i = 1 To Rng.Count
  FolderName = Rng(i)
 fName = Dir(MyPath & "\" & FolderName & "\" & "*.*")
  If Right(fName, 4) = ".doc" Or Right(fName, 4) = ".xls" Or Right(fName, 4) = ".pdf" Then
  While fName <> ""
    Cells(j, 1) = CStr(j - 1)
    Cells(j, 2) = FolderName
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(j, 3), Address:=MyPath & "\" & FolderName & "\" & fName, TextToDisplay:=fName
    fName = Dir
    j = j + 1
  Wend
  End If
Next
....

ThuNghi · 13/5/09

anhphuong đã viết:

Thu Nghi muốn thêm thuộc tính file thì sửa như sau :

PHP:

....
For i = 1 To Rng.Count
  FolderName = Rng(i)
 fName = Dir(MyPath & "\" & FolderName & "\" & "*.*")
  If Right(fName, 4) = ".doc" Or Right(fName, 4) = ".xls" Or Right(fName, 4) = ".pdf" Then
  While fName <> ""
    Cells(j, 1) = CStr(j - 1)
    Cells(j, 2) = FolderName
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(j, 3), Address:=MyPath & "\" & FolderName & "\" & fName, TextToDisplay:=fName
    fName = Dir
    j = j + 1
  Wend
  End If
Next
....

Có cách gì không if không.
Tự động luôn, khỏi mất công if
.ActiveDocument.BuiltinDocumentProperties(2)
và
.ActiveWorkbook.BuiltinDocumentProperties(2)
và ....
Cám ơn anh.

anhphuong · 18/5/09

ThuNghi đã viết:
Có cách gì không if không.
Tự động luôn, khỏi mất công if
.ActiveDocument.BuiltinDocumentProperties(2)
và
.ActiveWorkbook.BuiltinDocumentProperties(2)
và ....
Cám ơn anh.

Chưa tìm ra cách khác nhưng ThuNghi thử đoạn code này thế nào. Nó tim tất cả các file có type là msoFileTypeOfficeFiles

PHP:

...For i = 1 To Rng.Count
        FolderName = Rng(i)
        With Application.FileSearch
            .NewSearch
            .FileType = msoFileTypeOfficeFiles
            .LookIn = MyPath & "\" & FolderName
            .SearchSubFolders = False
            .Execute
            For m = 1 To .FoundFiles.Count
                Sheet2.Select
                Cells(m + 1, 1) = CStr(m)
                Cells(m + 1, 2) = FolderName
                fName = Dir(.FoundFiles(m))                
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(m + 1, 3), Address:=MyPath & "\" & FolderName & "\" & fName, TextToDisplay:=fName
                fName=Dir
            Next
        End With
    Next
....

Viết code tạo thư mục và sheet tương ứng với thư mục.

Thành viên hoạt động

Hãy để gió cuốn đi.

Thành viên hoạt động

Hãy để gió cuốn đi.

Thành viên hoạt động

Thành viên thường trực

Hãy để gió cuốn đi.

Hãy cho rồi sẽ nhận!

Hãy để gió cuốn đi.

Hãy cho rồi sẽ nhận!

Thành viên hoạt động

Hãy cho rồi sẽ nhận!

Hãy để gió cuốn đi.

Thành viên hoạt động

Thân Thương

Hãy cho rồi sẽ nhận!

File đính kèm

Thân Thương

Thân Thương

Hãy cho rồi sẽ nhận!

Thân Thương

Đếm ngược thời gian