【文件属性】：
文件名称：EXCEL.XLS中快速查找关键词VBA.rar
文件大小：22KB
文件格式：RAR
更新时间：2021-07-09 18:48:24
VBA 查找 excel
Option Explicit
Private Sub CommandButton1_Click()
Dim ar, br(), i&, j&, k&, m&, myFile$, myPath$, myStr$, Rng As Range, Wb, Ws, tms#
Application.ScreenUpdating = False
On Error Resume Next
If Range("n3") = "" Then MsgBox "N列中没有要查询的内容": Exit Sub
m = Range("n2").End(4).Row - 1
ar = Range("n2").Resize(m)
ReDim br(65530, 5)
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath = .SelectedItems(1) Else myPath = ThisWorkbook.Path
End With
If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
tms = Timer
myFile = Dir(myPath & "*.xls*")
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
br(k, 1) = Left(myFile, InStrRev(myFile, ".") - 1)
Set Wb = GetObject(ThisWorkbook.Path & "\" & myFile)
With Wb '利用GetObject在后台打开工作簿
For Each Ws In .Worksheets '循环当前工作簿中每个工作表
br(k, 2) = Ws.Name
With Ws
For i = 2 To m
myStr = ar(i, 1)
If WorksheetFunction.CountIf(.UsedRange, "*" & myStr & "*") <> 0 Then
Set Rng = .UsedRange.Find(myStr)
Do
br(k, 3) = Rng.Address(0, 0)
br(k, 4) = Rng.Text
br(k, 5) = myStr
br(k, 0) = k + 1
k = k + 1
br(k, 1) = br(k - 1, 1)
br(k, 2) = br(k - 1, 2)
Set Rng = .UsedRange.Find(myStr, Rng)
Loop While .UsedRange.Find(myStr).Address <> Rng.Address
End If
Next
End With
Next Ws
.Close False '不保存关闭工作簿
End With
End If
myFile = Dir
Loop
Set Wb = Nothing
Range("a1").CurrentRegion.Offset(2) = ""
myStr = "很遗憾、不存在你要搜索的内容。"
If k Then
Range("a3").Resize(k, 6) = br
Range("a3").Resize(k, 6).Borders.LineStyle = 1
以下还有内容……见附件！
【文件预览】：
查找关键词.xls