如何在硬盘中查找其中一个单元格中的一个人名

浏览所有文件包括子目录下的文件名到数组，然后做个循环分别打开文件并取名字就可以了。

我看你们公司还是请人开发一个档案管理系统

一个文件还包括sheet1，sheet2，关键好多文件，这是公司10年前的账了，当时命名很乱，现在要调出一个人的账，上千个文件夹咋找，领导要求没办法

有个软件叫everything，很好用

Option Explicit
Const defaultname = "赵日天"
Sub test()
　　Dim path, fso, filenames(), n As Long
　　On Error GoTo Errmsg
　　path = "d:\abc": MsgBox "在弹出窗口之前不要再次运行此过程！"
　　path = IIf(Right(path, 1) = "\", Left(path, Len(path) - 1), path)
　　If Dir(path, vbDirectory) = vbNullString Then MsgBox "未发现指定文件夹：" & path: Exit Sub
　　Set fso = CreateObject("Scripting.FileSystemObject")
　　getsubfolderfils fso, path, filenames, n
　　If n > 0 Then
　　　n = 0
　　　If findnameinsheets(filenames, n) Then
　　　　[a:a].ClearContents
　　　　[a1].Resize(n, 1) = WorksheetFunction.Transpose(filenames): MsgBox "ok!"
　　　Else
　　　　MsgBox "未在excel文档中找到指定名字：" & defaultname & vbNewLine & "或处理文件时发生错误！"
　　　End If
　　Else
　　　MsgBox "指定文件夹下未发现excel文件！"
　　End If
Exit Sub
Errmsg:
　MsgBox "创建对象失败：Scripting.FileSystemObject"
End Sub
Function getsubfolderfils(fso, path, filenames, n)
　　Dim p, f, s
　　On Error GoTo Errmsg
　　For Each f In fso.GetFolder(path).Files
　　　　s = path & "\" & f.Name
　　　　If LCase(Right(s, 5)) = ".xlsx" Or LCase(Right(s, 4)) = ".xls" Then
　　　　　n = n + 1: ReDim Preserve filenames(1 To n)
　　　　　filenames(n) = s
　　　　End If
　　Next
　　For Each p In fso.GetFolder(path).subfolders
　　　　getsubfolderfils fso, path & "\" & p.Name, filenames, n
　　Next
Exit Function
Errmsg:
　n = 0: MsgBox "读取文件名错误或当前用户权限不够！"
End Function
Function findnameinsheets(filenames, n) As Boolean
　Dim i, xlsWorkbook, xlsapp, sht, rng, flag As Boolean
　On Error GoTo Errmsg
　Set xlsapp = CreateObject("Excel.Application")
　For i = 1 To UBound(filenames)
　　Set xlsWorkbook = xlsapp.Workbooks.Open(filenames(i))
　　xlsapp.Visible = False
　　　For Each sht In xlsapp.Sheets
　　　　For Each rng In sht.UsedRange
　　　　　If rng.Value = defaultname Then
　　　　　　n = n + 1: filenames(n) = filenames(i) & Space(4) & sht.Name & Space(4) & rng.Address
　　　　　　flag = True: Exit For
　　　　　End If
　　　　　DoEvents
　　　　Next
　　　　If flag Then flag = False: Exit For
　　　Next
　　　DoEvents: xlsWorkbook.Close False
　Next
　xlsapp.Visible = True: Set xlsWorkbook = Nothing: Set xlsapp = Nothing
　If n > 0 Then findnameinsheets = True
Exit Function
Errmsg:
　MsgBox "创建excel对象失败" & vbNewLine & "或当前文件已打开或文件已损坏:" & filenames(i)
　xlsapp.Visible = True: Set xlsWorkbook = Nothing: Set xlsapp = Nothing
End Function