VBA 在指定目录及其子目录中的excel文件中检索指定的文字列

效果图：
[img]http://dl2.iteye.com/upload/attachment/0121/5397/182b84b1-4557-3a19-8623-8f6a7eb3d5d9.png[/img]
对应的代码入下：

对应的代码入下：

Sub getColumn()

    Dim work1 As Workbook
    Dim path, keyWord As String
    Dim fileContent As String
    Dim unFoundCol As String

    ' 指定检索的目录
    path = ThisWorkbook.Sheets(2).Range("F1").Value
    '指定的检索文字列
    keyWord = ThisWorkbook.Sheets(2).Range("F2").Value
    If IsEmpty(path) Then
        MsgBox ("请输入路径")
        Exit Sub
    End If
     If IsEmpty(keyWord) Then
        MsgBox ("请输入检索路径")
        Exit Sub
    End If
    fileContent = searchKeyWord(path, keyWord)

    MsgBox ("检索完成")

End Sub

' 检索函数
Function searchKeyWord(path, keyWord)
    Dim j As Integer
    Dim MyFile, MyPath, MyName
    Dim file() As String
    Dim Wb As Workbook, Ws As Worksheet, FN$
    Dim i, k, x
    j = 6
    i = 1
    k = 1
    x = 1

    ReDim file(1 To i)
    file(1) = path & "\"
    Do Until i > k
    FN = Dir(file(i), vbDirectory)     '获取文件夹下的文件

        Do Until FN = ""
            If InStr(FN, ".") = 0 Then '如果是个文件夹，则将该文件夹添加到检索目录里

                k = k + 1

                ReDim Preserve file(1 To k)

                file(k) = file(i) & FN & "\"
            Else
                 If InStr(FN, ".xls") > 0 Then
                    Set Wb = GetObject(file(i) & "\" & FN)    'OPEN File
                    With Wb
                        For Each Ws In .Worksheets  '循环每个sheet检索

                            With Ws
                                If WorksheetFunction.CountIf(.UsedRange, "*" & keyWord & "*") <> 0 Then  '在每个sheet的活动区检索文字列       

                                   ThisWorkbook.Sheets(2).Range("A" & j).Value = file(i)
                                    ThisWorkbook.Sheets(2).Range("B" & j).Value = FN
                                    ThisWorkbook.Sheets(2).Range("C" & j).Value = Ws.Name '检索到输出，可以改成自己想要的格式
                                    j = j + 1
                                    GoTo nextFound
                                 End If
                            End With
                            Next Ws
                      End With
                      Wb.Close False  '关闭excel文件不保存

                End If
           End If
nextFound:   FN = Dir  '检索下一个文件
       Loop
    i = i + 1
    Loop
End Function