vba递归子文件夹excel文件，实现关键词搜索

‘module 1

Public d

Public findString

Sub button_Click()

Application.ScreenUpdating = False

ActiveSheet.UsedRange.ClearContents

rem Cells(1, 1) = “stringFind”

findString=cells(1,1)

Set d = CreateObject(“scripting.dictionary”)

Getfd (ThisWorkbook.Path) ‘ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改

Application.ScreenUpdating = True

If d.Count > 0 Then

ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)

ThisWorkbook.Sheets(1).[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)

End If

End Sub

Sub Getfd(ByVal pth)

Set Fso = CreateObject(“scripting.filesystemobject”)

Set ff = Fso.getfolder(pth)

For Each f In ff.Files

Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理

If InStr(Split(f.Name, “.”)(UBound(Split(f.Name, “.”))), “xl”) > 0 and not （left（f.Name,1）=”～”） Then

If f.Name <> ThisWorkbook.Name Then

Set wb = Workbooks.Open(f)

For Each sht In wb.Sheets

If WorksheetFunction.CountA(sht.UsedRange) > 1 Then

arr = sht.UsedRange

rem For j = 2 To UBound(arr)

rem d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)

rem Next j

rem handle each data of a sheet

call handle_find(arr,pth,f)

End If

Next sht

wb.Close False

End If

End If

Next f

For Each fd In ff.subfolders

Getfd (fd)

Next fd

End Sub

sub handle_find(arr,pth,f)

For r = 1 To UBound(arr)

For j = 1 To UBound(arr, 2)

If arr(r, j) = findString Then

rem need test

d(pth & “\” & f.name)=””

Exit For

End If

next

next

end sub