- Tham gia
- 30/5/06
- Bài viết
- 1,798
- Được thích
- 4,706
- Giới tính
- Nam
Trong topic này chúng ta sẽ được xem các đoạn code của các lập trình viên VBA (thường là các chuyên gia). Các đoạn code này đã được kiểm chứng nên các bạn có thể yên tâm sử dụng chúng.
Lưu ý rằng, các đoạn code chỉ thực hiện một cách tổng quát chủ đích đưa ra. Còn việc áp dụng vào từng vấn đề của các bạn, các bạn vui lòng chỉnh sửa theo ý của mình.
1. Làm việc với các tập tin
Liệt kê các tập tin trong một thư mục:
Code của Nathan P. Oliver
Chương trình sẽ liệt kê: tên tập tin, kích thước, ngày chỉnh sửa của tất cả các tập tin trong thư mục được chọn và cả thư mục con của thư mục được chọn.
Mã:
Sub ExcelFileSearch()
Dim srchExt As Variant, srchDir As Variant, i As Long, j As Long
Dim strName As String, varArr(1 To 1048576, 1 To 3) As Variant
Dim strFileFullName As String
Dim ws As Worksheet
Dim fso As Object
Let srchExt = Application.InputBox("Please Enter File Extension", "Info Request")
If srchExt = False And Not TypeName(srchExt) = "String" Then
Exit Sub
End If
Let srchDir = BrowseForFolderShell
If srchDir = False And Not TypeName(srchDir) = "String" Then
Exit Sub
End If
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("FileSearch Results").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ws.Name = "FileSearch Results"
Let strName = Dir$(srchDir & "\*" & srchExt)
Do While strName <> vbNullString
Let i = i + 1
Let strFileFullName = srchDir & strName
Let varArr(i, 1) = strFileFullName
Let varArr(i, 2) = FileLen(strFileFullName) \ 1024
Let varArr(i, 3) = FileDateTime(strFileFullName)
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(srchDir), varArr(), i, CStr(srchExt))
Set fso = Nothing
ThisWorkbook.Windows(1).DisplayHeadings = False
With ws
If i > 0 Then
.Range("A2").Resize(i, UBound(varArr, 2)).Value = varArr
For j = 1 To i
.Hyperlinks.Add anchor:=.Cells(j + 1, 1), Address:=varArr(j, 1)
Next
End If
.Range(.Cells(1, 4), .Cells(1, .Columns.Count)).EntireColumn.Hidden = True
.Range(.Cells(.Rows.Count, 1).End(xlUp)(2), _
.Cells(.Rows.Count, 1)).EntireRow.Hidden = True
With .Range("A1:C1")
.Value = Array("Full Name", "Kilobytes", "Last Modified")
.Font.Underline = xlUnderlineStyleSingle
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef varArr() As Variant, _
ByRef i As Long, _
ByRef srchExt As String)
Dim SubFolder As Object
Dim strName As String, strFileFullName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "\*" & srchExt)
Do While strName <> vbNullString
Let i = i + 1
Let strFileFullName = SubFolder.Path & "\" & strName
Let varArr(i, 1) = strFileFullName
Let varArr(i, 2) = FileLen(strFileFullName) \ 1024
Let varArr(i, 3) = FileDateTime(strFileFullName)
Let strName = Dir$()
Loop
If i > 1048576 Then Exit Sub
Call recurseSubFolders(SubFolder, varArr(), i, srchExt)
Next
End Sub
Private Function BrowseForFolderShell() As Variant
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, "C:\")
If Not objFolder Is Nothing Then
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then
BrowseForFolderShell = CStr(objFolder)
Else
On Error GoTo 0
If Len(objFolder.Items.Item.Path) > 3 Then
BrowseForFolderShell = objFolder.Items.Item.Path & _
Application.PathSeparator
Else
BrowseForFolderShell = objFolder.Items.Item.Path
End If
End If
Else
BrowseForFolderShell = False
End If
Set objFolder = Nothing: Set objShell = Nothing
End FunctionLê Văn Duyệt
Nguồn: MrExcel Library
Lần chỉnh sửa cuối:
