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