用VBA遍历电脑所有文件夹找出修改时间最近且文件名包含“稿件”这个文件

415903035

fdhj;谢谢各位

titi012

参考一下。楼主精神可嘉！

titi012

1、在文件对话框选择要查找的文件（最高一级）
2，输入要查找的文件名的关键字，不输入的话就会得到全的文档（不包括文件夹）
代码如下：

1. Option Explicit
   
2. Dim Nrr(), Q As Long
   
3. Sub FindFileSub()
   
4.     Dim S As String, T As String
   
5.     S = SelectFile()
   
6.     If S = "" Then Exit Sub
   
7.     T = InputBox("请输入关键字：", "查询关键字")
   
8.     T = "*" & T & "*"
   
9.     Q = 0
   
10.     DirSub S, T
    
11.     [a:b].Clear
    
12.     If Q = 0 Then Exit Sub
    
13.     With Range("a1").Resize(Q, 2)
    
14.         .Value = WorksheetFunction.Transpose(Nrr)
    
15.         .Sort key1:=[b1], order1:=2
    
16.     End With
    
17. End Sub
    
18. Private Sub DirSub(ByVal S As String, T As String)
    
19.     Dim S1 As String, Trr() As String, a&
    
20.     On Error Resume Next
    
21.     S1 = Dir(S & T)
    
22.     Do Until S1 = ""
    
23.         Q = Q + 1
    
24.         ReDim Preserve Nrr(1 To 2, 1 To Q)
    
25.         Nrr(1, Q) = S & S1
    
26.         Nrr(2, Q) = FileDateTime(Nrr(1, Q))
    
27.         S1 = Dir
    
28.     Loop
    
29.     a = 0
    
30.     S1 = Dir(S, vbDirectory)
    
31.     Do
    
32.         If S1 <> "." And S1 <> ".." And GetAttr(S & S1) = vbDirectory Then
    
33.             a = a + 1
    
34.             ReDim Preserve Trr(1 To a)
    
35.             Trr(a) = S & S1 & ""
    
36.         End If
    
37.         S1 = Dir
    
38.     Loop While S1 <> ""
    
39.     If a = 0 Then Exit Sub
    
40.     For a = 1 To UBound(Trr)
    
41.         DirSub Trr(a), T
    
42.     Next
    
43.     On Error GoTo 0
    
44. End Sub
    
45. Function SelectFile() As String '//选择文件夹。返回一个文本。
    
46.     With Application.FileDialog(msoFileDialogFolderPicker)
    
47.         If .Show = True Then SelectFile = .SelectedItems(1)
    
48.     End With
    
49.     If SelectFile = "" Then Exit Function
    
50.     If Right(SelectFile, 1) <> "" Then SelectFile = SelectFile & ""
    
51. End Function

复制代码