[發問] 多層資料夾尋找檔案的問題

帖子: 73
主題: 11
精華: 0
積分: 100
點名: 0
作業系統: Win 8
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2013-5-11
最後登錄: 2018-7-25

論壇榮譽勳章論壇贊助勳章

2^#

發表於 2014-3-8 20:02 | 只看該作者

看到一個標題是這樣的:
"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

我試過他會列出所有資料夾的名稱，但有個小小疑問，要怎麼利用dir去尋找這清單然後打開要的檔案?有大大可以教我一下嗎? 由衷感謝^^

Sub go()
      ShowFolderList ("C:\temp")
End Sub

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

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 247
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-14

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

3^#

發表於 2014-3-8 22:48 | 只看該作者

回復 2# ui123

http://gb.twbts.com/index.php/topic,1877.0.html

學海無涯_不恥下問

帖子: 73
主題: 11
精華: 0
積分: 100
點名: 0
作業系統: Win 8
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2013-5-11
最後登錄: 2018-7-25

論壇榮譽勳章論壇贊助勳章

4^#

發表於 2014-3-9 09:50 | 只看該作者

回復 3# Hsieh

親愛的版主您好~
我有連進去囉->Excel程式區 1877.0 html 是什麼? 不懂，感恩^^

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 247
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-14

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

5^#

發表於 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 的特點：
因為它是物件，擁有許多屬性和方法，可以做更靈活的運用。

檔案比對 / 目錄操作 (GetFolder)
存檔時如何得知其他幾個資料夾裡已有相同名稱的檔案存在 (已存在檔案有可能是隱藏)??

可在巨集中使用 FileSystem 物件來搜尋比對, 會包含隱藏檔.
假設這五個資料夾位於 C:\My Documents。

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 "該檔案為隱藏檔!"

判斷檔案是否存在 (FileExists)
如何判斷欲開啟的檔案是否存在，若存在則開啟之，若不存在則開啟新檔並命名為指定的檔名，若該檔案已經開啟則使該檔案成為作用中的檔案？

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

[說明]
1 顯示對話框, 輸入檔名 (要含副檔名)
2 如果沒輸入或按了取消則傳回空字串, 結束巨集
3 對已開啟的每個視窗(檔案)做迴圈比對
4 若視窗標題 = 輸入的檔名則設變數 x = True, 結束迴圈
　(使用 UCase 函數轉換為大寫以便於比對)
5 若 x 為 True 則使該檔案成為使用中視窗
6 建立一個 FileSystem 物件, 以作磁碟檔案處理
7 若指定的檔案不存在
8 開新檔案並存為指定的檔名
9 否則開啟指定的檔案
0 結束 If 判斷

[註]
‧為說明之便而加上程式行號, 一般是不需要的
‧範例針對"目前"資料夾, 有需要請自行加上路徑

Dir / FileSystem 應用比較
有大量的Excel檔, 其中要把某些字串改成別的字串, 比如所有的aaa要改成bbb。

假設檔案都放在 D:\Temp 資料夾之下,
要把其中所有 Excel 檔中的 aaa 取代為 bbb.
磁碟/檔案的處理不外乎 Dir函數和 Filesystem Object 兩種方法.

一. 使用 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

學海無涯_不恥下問

帖子: 73
主題: 11
精華: 0
積分: 100
點名: 0
作業系統: Win 8
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2013-5-11
最後登錄: 2018-7-25

論壇榮譽勳章論壇贊助勳章

6^#

發表於 2014-3-9 19:28 | 只看該作者

回復 5# Hsieh

版大我有看完你PO的文，Sub list_and_link1 可以列出所有檔案名
----------------------------------------------------------------------------------------------------------
另外也找了一種方法，它可以幫我找出所有檔案名稱，但有個小小問題，
如果Sheet1的Range("A1") 是搜尋的檔名，例如:file(如主題中的附件)，如何在搜尋到後打開他???感謝您^^

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

帖子: 73
主題: 11
精華: 0
積分: 100
點名: 0
作業系統: Win 8
軟體版本: 2007
閱讀權限: 20
性別: 女
註冊時間: 2013-5-11
最後登錄: 2018-7-25

論壇榮譽勳章論壇贊助勳章

7^#

發表於 2014-3-12 22:24 | 只看該作者

各位大大，給您們回報目前狀況

暫時方案:
目前無法解決"Dir在各subfolder找到檔案就開起來(檔案只存在一個資料夾)"
所以現在暫時應應措施為: 先列出所有的檔案名，然後搜出要的檔案名+完整位置，然後打開它~
---------------------------------------------------------------------------------------------
永久對策:
如有人會"Dir各subfolder"然後打開找到的檔案的話，請不令指教，感謝~^^
PS:要找的檔案名會放在A1儲存格