看到一個標題是這樣的:
"Excel VBA to list files in folder and subfolder with path to .txt file"
如下網址:
http://stackoverflow.com/questions/20219362/excel-vba-to-list-files-in-folder-and-subfolder-with-path-to-txt-file
Sub ShowFolderList(folderspec)
Dim fs, f, f1, fc, s, sFldr
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.SubFolders
For Each f1 In fc
ShowFolderList f1
Next
Set fc = f.Files
For Each f1 In fc
Debug.Print folderspec & f1.Name
Next
End Sub作者: Hsieh 時間: 2014-3-8 22:48
親愛的版主您好~
我有連進去囉->Excel程式區 1877.0 html 是什麼? 不懂，感恩^^作者: Hsieh 時間: 2014-3-9 10:10
本帖最後由 Hsieh 於 2014-3-9 10:20 編輯
Dir 函數 - 基本的檔案/資料夾讀取方式
Sub 列出檔案()
path1 = "C:\Temp\*.*"
file1 = Dir(path1): r = 1
Do While file1 <> ""
Cells(r, 1) = file1
r = r + 1
file1 = Dir '取得下一個檔名
Loop
End Sub
Dir 基本應用範例
對一個已被其他電腦(非本機)以資源共享方式開啟的xls檔，有沒有什麼方法來偵測或描述它的屬性或狀態，以表示它是一個「目前已被開啟使用中」的檔案??
以下的巨集會把本機和指定目錄下使用中的xls檔列出。
Sub CheckFile()
Application.ScreenUpdating = False
Range("A1") = "本機已開啟檔案"
For Each book In Workbooks
GoSub 1: Cells(r, 1) = book.FullName
Next
mypath = "C:\": GoSub 1
myfile = Dir(mypath & "*.xls")
Cells(r, 1) = "他人使用中檔案"
Do While myfile <> "" ' 執行迴圈
GoSub 1: myfilename = mypath & myfile
Workbooks.Open myfilename
If ActiveWorkbook.ReadOnly Then Cells(r, 1) = myfilename
Workbooks(myfile).Close
myfile = Dir ' 尋找下一個檔案
Loop: Exit Sub
1 r = Application.WorksheetFunction.CountA(Columns(1)) + 1: Return
End Sub
註：資料夾分享模式應設定為「完整」，否則偵測不到。
Dir 進階應用範例
列出指定目錄之下所有的子資料夾內容。
Sub list_and_link1()
Dim ary() As String, rw As Long
rw = 1: i = 0
path1 = "C:\myArticle\"
file1 = Dir(path1 & "*.*", vbDirectory) '只處理資料夾
Do While file1 <> ""
If file1 <> "." And file1 <> ".." And _
GetAttr(path1 & file1) = vbDirectory Then
i = i + 1
ReDim Preserve ary(i)
ary(i) = file1
End If
file1 = Dir
Loop
For i = 1 To UBound(ary)
Cells(rw, 1) = ary(i)
rw = rw + 1
GetSubs path1 & ary(i) & "\", rw, 1
Next i
file1 = Dir(path1 & "*.*")
Do While file1 <> ""
'此例只列出檔名, 你可寫上要做的動作
Cells(rw, 1) = file1
rw = rw + 1
file1 = Dir
Loop
End Sub
Sub GetSubs(sPath As String, rw As Long, ilevel As Long)
Dim ary1() As String
ReDim ary1(1)
sName = Dir(sPath, vbDirectory)
Do While sName <> ""
If sName <> "." And sName <> ".." And _
GetAttr(sPath & sName) = vbDirectory Then
ary1(UBound(ary1)) = sName
ReDim Preserve ary1(UBound(ary1) + 1)
End If
sName = Dir
Loop
For i = 1 To UBound(ary1) - 1
Cells(rw, ilevel + 1) = ary1(i)
rw = rw + 1
GetSubs sPath & ary1(i) & "\", rw, ilevel + 1
Next i
sName = Dir(sPath & "*.*")
Do While sName <> ""
Cells(rw, ilevel + 1) = sName
rw = rw + 1
sName = Dir
Loop
End Sub
--------------------------------------
Dir 函數的特點：
用於取得檔案或目錄的名稱，適合基本的需求。
FileSystem object 的特點：
因為它是物件，擁有許多屬性和方法，可以做更靈活的運用。
Sub 檢查檔案( )
檔名 = InputBox("請輸入檔名 (包含副檔名)：")
If 檔名 = "" Then Cancel = True: Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
Set sf = fs.GetFolder("C:\My Documents").SubFolders
For Each f In sf
For Each f1 In f.Files
If f1.Name = 檔名 Then
MsgBox 檔名 & " 已存在於 " & f.Name & " 資料夾!"
a = 1: Exit For
End If
Next
Next
If a = 1 Then Cancel = True
End Sub
若仍想得知該檔案是否為隱藏檔, 可使用下列程式碼 :
If f1.Attributes And 2 Then MsgBox "該檔案為隱藏檔!"
1 檔名 = InputBox("請輸入檔名：")
2 If 檔名 = "" Then Exit Sub
3 For Each win In Windows
4 If UCase(win.Caption) = UCase(檔名) Then x = True: Exit For
5 Next: If x Then win.Activate: Exit Sub
6 Set fs = CreateObject("Scripting.FileSystemObject")
7 If Not fs.FileExists(檔名) Then
'8 Set newfile = Workbooks.Add
'0 newfile.SaveAs 檔名
8 Workbooks.Add.SaveAs 檔名
9 Else: Workbooks.Open 檔名
0 End If
一. 使用 Dir 函數
Sub 取代一大堆()
p = "D:\Temp\"
f = Dir(p & "*.xls")
Do While f <> ""
Workbooks.Open p & f
For Each sh In Worksheets
sh.Cells.Replace "aaa", "bbb", xlPart
Next
ActiveWorkbook.Close True '存檔並關閉
f = Dir
Loop
End Sub
二. 使用 Filesystem Object
Sub 取代一大堆()
Set fs = CreateObject("Scripting.FileSystemObject")
Set fd = fs.GetFolder("D:\Temp") '取得資料夾
For Each f In fd.Files
If fs.GetExtensionName(f.Name) = "xls" Then '取得副檔名
Workbooks.Open f.Path
For Each sh In Worksheets
sh.Cells.Replace "aaa", "bbb", xlPart
Next
ActiveWorkbook.Close True
End If
Next
End Sub作者: ui123 時間: 2014-3-9 19:28
Public Sub TestListDir()
Worksheets(1).Cells(2, 1).Activate
Call listDir("C:\Users\ui\Desktop\New folder\", 1)
End Sub
Public Sub listDir(strPath As String, lngSheet As Long)
Dim strFn As String
Dim strDirList() As String
Dim lngArrayMax, x As Long
lngArrayMax = 0
strFn = Dir(strPath & "*.*", 23)
While strFn <> ""
If strFn <> "." And strFn <> ".." Then
If (GetAttr(strPath & strFn) And vbDirectory) = vbDirectory Then
lngArrayMax = lngArrayMax + 1
ReDim Preserve strDirList(lngArrayMax)
strDirList(lngArrayMax) = strPath & strFn & "\"
Else
ActiveCell.Value = strPath & strFn
Worksheets(lngSheet).Cells(ActiveCell.Row + 1, 1).Activate
End If
End If
strFn = Dir()
Wend
If lngArrayMax <> 0 Then
For x = 1 To lngArrayMax
Call listDir(strDirList(x), lngSheet)
Next
End If
End Sub作者: ui123 時間: 2014-3-12 22:24
