返回列表 上一主題 發帖

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

回復 10# GBKEE


    超版大大,實在太神了

多學了一個InStr的用法,真好用耶

至於Set Fs = CreateObject("Scripting.FileSystemObject").GetDRIVE("C:")
    Set Fs = Fs.ROOTFOLDER.SubFolders '根目錄\資料夾物件集合
也是小弟第一次看到
好方便!

感激至極!!
PKKO

TOP

本帖最後由 no3-taco 於 2015-6-16 04:36 編輯

玩玩看,簡化過的遞迴版
  1. Sub 這裡執行()
  2. Dim rw As Long, ilevel As Long: rw = 1: ilevel = 0
  3. GetSubs "C:\Users\Administrator\Desktop" & "\", rw, ilevel '呼叫副程式"#修改路徑#
  4. End Sub
  5. Sub GetSubs(sPath As String, rw As Long, ilevel As Long)
  6. Dim ary1() As String: ReDim ary1(0): Dim sName
  7. sName = Dir(sPath, vbDirectory)
  8. Do While sName <> ""
  9.     On Error Resume Next  '有錯誤跳過
  10.     If sName <> "." And sName <> ".." And (GetAttr(sPath & sName) And vbDirectory) = vbDirectory Then
  11.     'If Err = 0 Then  '沒有錯誤時
  12.         ReDim Preserve ary1(UBound(ary1) + 1)
  13.         ary1(UBound(ary1)) = sName
  14.     End If ': End If
  15.     sName = Dir
  16. Loop
  17. For i = 1 To UBound(ary1)
  18.     rw = rw + 1
  19.     GetSubs sPath & ary1(i) & "\", rw, ilevel + 1    '遞迴呼叫
  20. Next i
  21. sName = Dir(sPath)
  22. If Dir(sPath & [A1]) = [A1] Then
  23.    Workbooks.Open sPath & [A1]    '開啟檔案
  24. End
  25. End If
  26. End Sub
複製代碼

TOP

回復 8# Hsieh
大大最近使用這個程式碼時,發現常常搜個2~3層就不搜了(沒在搜下去,原始資料夾共有24個 2014/1..../12 &2015/1..../12),
很怪><,不過有的時候時成功的

TOP

本帖最後由 准提部林 於 2015-9-9 17:27 編輯

回復 13# ui123


2003以上沒了 FileSearch,對這多層搜檔實在頭痛,不是專行寫的,參考看看!
A1請先輸入〔檔案名稱.副檔名〕,僅搜索執行檔案同一層及以下子資料夾的檔案,
若與實際需求有不足點,請自行修改:
  1. Sub Get_File()
  2. Dim OBJ, xD, xFile$, Urr, U, G, GF, K, xB As Workbook
  3. Set OBJ = CreateObject("Scripting.FileSystemObject")
  4. Set xD = CreateObject("Scripting.Dictionary")
  5. Urr = Array(ThisWorkbook.Path)
  6.  
  7. RE_GET:
  8. For Each U In Urr
  9.   xFile = U & "\" & [A1].Value  '檔案夾路徑+A1檔名.副檔名
  10.   If Dir(xFile) <> "" Then Set xB = Workbooks.Open(xFile): Exit Sub  '找到檔案,開啟並跳出
  11.  
  12.   Set GF = OBJ.GetFolder(U).SubFolders   '取得本層子資夾
  13.   If GF.Count > 0 Then     
  14.     For Each G In GF: K = K + 1: xD(K) = G.Path: Next  '將子資料夾納入字典檔
  15.   End If
  16. Next
  17.  
  18. If K > 0 Then Urr = xD.items: xD.RemoveAll: K = 0: GoTo RE_GET '若字典檔有內容,再去找檔案
  19. MsgBox "找不到目標檔案! "
  20. End Sub
複製代碼
 

TOP

回復 7# ui123
  1. '使用FSO搜索文件或是文件夹
  2. Public Function FSOFileSearch(Optional ByVal SearchPath As String, _
  3.          Optional ByVal objFolder As Object = Nothing, _
  4.          Optional ByVal SearchName As String = vbNullString, _
  5.          Optional ByVal SearchSub As Boolean = True, _
  6.          Optional ByVal SearchType As Long = 1) As Collection
  7.         Dim FSO       As Object
  8.         Dim Filter()  As String
  9.         Dim subSearch As Collection
  10.         Dim I As Long, J As Long
  11.         Dim objSub    As Object
  12.         
  13. 1       Set FSOFileSearch = New Collection
  14. 2       If objFolder Is Nothing Then
  15. 3         If Len(SearchPath) = 0 Then Exit Function
  16. 4         Set FSO = CreateObject("Scripting.FileSystemObject")
  17. 5         Set objFolder = FSO.GetFolder(SearchPath)
  18. 6         Set FSO = Nothing
  19. 7         If objFolder Is Nothing Then Exit Function
  20. 8       End If
  21.         
  22. 9       If Len(SearchName) < 1 Then SearchName = "*.*|*"
  23. 10      Filter = Split(Replace(SearchName, "|", vbNullChar), vbNullChar)
  24. 11      If Len(SearchPath) Then
  25. 12        For I = 0 To UBound(Filter)
  26. 13          Filter(I) = LCase$(Trim$(Filter(I)))
  27. 14          If Len(Filter(I)) = 0 Then
  28. 15            If I = UBound(Filter) Then Exit For
  29. 16            For J = I + 1 To UBound(Filter)
  30. 17              If Len(Filter(J)) Then
  31. 18                Filter(I) = Filter(J)
  32. 19                Filter(J) = vbNullString
  33. 20                I = J - 1
  34. 21                Exit For
  35. 22              End If
  36. 23            Next J
  37. 24            If J > UBound(Filter) Then Exit For
  38. 25          End If
  39. 26        Next I
  40. 27        ReDim Preserve Filter(I - 1)
  41. 28        SearchName = Join(Filter, vbNullChar)
  42. 29      End If
  43.         
  44. 30      If SearchType And 1& Then
  45. 31        For Each objSub In objFolder.Files
  46. 32          With objSub
  47. 33            For I = 0 To UBound(Filter)
  48. 34              If LCase(.Name) Like Filter(I) Then
  49. 35                FSOFileSearch.Add .Path
  50. 36                Exit For
  51. 37              End If
  52. 38            Next I
  53. 39          End With
  54. 40        Next objSub
  55. 41      End If
  56.         
  57. 42      If SearchType And 2& Then
  58. 43        For Each objSub In objFolder.SubFolders
  59. 44          With objSub
  60. 45            For I = 0 To UBound(Filter)
  61. 46              If LCase(.Name) Like Filter(I) Then
  62. 47                FSOFileSearch.Add .Path
  63. 48                Exit For
  64. 49              End If
  65. 50            Next I
  66. 51          End With
  67. 52        Next objSub
  68. 53      End If
  69.         
  70. 54      If SearchSub Then
  71. 55        For Each objSub In objFolder.SubFolders
  72. 56          DoEvents
  73. 57          Set subSearch = FSOFileSearch(, objSub, SearchName, SearchSub, SearchType)
  74. 58          With subSearch
  75. 59            For J = 1 To .Count
  76. 60              FSOFileSearch.Add .Item(J)
  77. 61            Next J
  78. 62          End With
  79. 63          Set subSearch = Nothing
  80. 64        Next objSub
  81. 65      End If
  82. End Function

  83. Sub TestSearch()
  84.   Dim I       As Long
  85.   Dim Search  As Collection

  86.   Set Search = FSOFileSearch(ThisWorkbook.Path, , [A1], True, 1)
  87.   For I = 1 To Search.Count
  88.     Workbooks.Open Search(I)
  89.   Next I
  90. End Sub
複製代碼
要注意的是如果A1单元格中的内容包含匹配字符,将会被如期使用,比如A1中输入*.*|*将会搜索出指定路径中的所有文件,*.XLS[XM]则表示搜索后缀为.XLSX及.XLSM文件(与*.XLSX|*.XLSM相同,|表示Or)。A1中的内容只能包含文件名,而最好不要包含目录名。

TOP

其實幾天前已想請問, 查詢維一檔案的最簡單而快方法可能是 dos 的 dir/s , 但目前衹懂得先導入 txt 檔案, 如 先設定 findx ="cme.exe /c dir/s c:\file.txt > speciafyDrive:\reslt.txt", 然後引用 shell(finx), 再 open result.txt , 用instr 找"\" 確認檔案是否存在, 但這樣要先做一次寫入, 而我想問的是可否以直接將查詢資料寫入彈列中, 求知。

TOP

參考看看!簡單的FSO搜尋
  1. Sub 呼叫處() '呼叫處
  2. Dim FirstPath: FirstPath = "C:\Users\Administrator\Desktop\" '路徑....自行修改
  3.     SearchFile FirstPath
  4. End Sub

  5. Sub SearchFile(ByVal xPath As String)
  6. Dim objPath As Object, xFile As Object, xFolder As Object
  7. Set objPath = CreateObject("Scripting.FileSystemObject").getfolder(xPath)
  8. For Each xFile In objPath.Files         '該層檔案名稱集合
  9.     If xFile.Name = [a1] Then           '開啟的檔案名稱....自行修改
  10.         Workbooks.Open xFile.Path       '開啟檔案
  11.         End
  12.     End If
  13. Next
  14. For Each xFolder In objPath.SubFolders '某層子資料夾集合
  15.     SearchFile xFolder.Path
  16. Next
  17. End Sub
複製代碼

TOP

回復 16# ikboy

那個CMD的也不太懂, 試著寫, 參考看看:
http://forum.twbts.com/thread-15063-1-1.html

TOP

回復 8# Hsieh
今天試,各層都蒐的到了
我在研究一下....還沒發現其他問題,有問題再問您,謝謝~

TOP

        靜思自在 : 君子如水,隨方就圓,無處不自在。
返回列表 上一主題