最近專案需要，寫了一個小工具，查找檔案夾下的所有excel，能夠不區分大小寫，不區分全角半角，在cell和容器里面搜索要查找的內容，給大家分享一下
Private Sub searchEnvorement_Click()
Dim Dic, Wb As Workbook, Ws As Worksheet, Arr, N&, FN$, listsize%, Rng As Range, Str2$, groupcount%, keyList() As String, no1%
no1 = 0
Set thswb = ThisWorkbook.ActiveSheet
Set Dic = CreateObject("scripting.dictionary")
MyPath = thswb.Range("H2")
listsize = thswb.Range("A65536").End(xlUp).Row
ReDim keyList(listsize - 1)
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
For i = 1 To listsize
'檢索關鍵字
keyList(i - 1) = Worksheets("keyList").Range("A" & i).Value
Next i
Application.ScreenUpdating = False
On Error Resume Next
FN = Dir(MyPath & "*.xls*")
Do While FN <> ""
If FN <> ThisWorkbook.Name Then
Set Wb = CreateObject(MyPath & FN)
For j = 0 To listsize - 1
searchKey = keyList(j)
With Wb
For Each Ws In .Worksheets
With Ws
If InStr(1, .UsedRange, searchKey, 1) Then
Set Rng = .UsedRange.Find(searchKey, , , , , , , False)
Do
Str2 = Wb.Name & vbTab & Ws.Name & vbTab & Replace(Rng.Address, "$", "") & vbTab & Rng.Value & vbTab & searchKey
If Not Dic.exists(Str2) Then Dic.Add Str2, ""
Set Rng = .UsedRange.Find(searchKey, Rng, , , , , , False)
Loop While .UsedRange.Find(searchKey, , , , , , , False).Address <> Rng.Address
End If
For Each Sp In .Shapes
If Sp.Type <> 6 And InStr(1, Sp.TextEffect.Text, searchKey, 1) Then
Str2 = Wb.Name & vbTab & Ws.Name & vbTab & vbTab & Sp.Name & ":" & Sp.TextEffect.Text & vbTab & searchKey
If Not Dic.exists(Str2) Then Dic.Add Str2, ""
End If
If Sp.Type = 6 Then
groupcount = Sp.GroupItems.Count
For k = 1 To groupcount
If InStr(1, Sp.GroupItems(k).TextEffect.Text, searchKey, 1) Then
Str2 = Wb.Name & vbTab & Ws.Name & vbTab & vbTab & Sp.GroupItems(k).Name & ":" & Sp.GroupItems(k).TextEffect.Text & vbTab & searchKey
If Not Dic.exists(Str2) Then Dic.Add Str2, ""
End If
Next k
End If
Next Sp
End With
Next Ws
End With
Next j
no1 = no1 + 1
Wb.Close False
End If
FN = Dir
Set Wb = Nothing
Loop
Worksheets.Add
ActiveSheet.Name = "searchList"
With Worksheets("searchList")
.Rows("3:" & .Rows.Count).Clear
.Cells(2, 1) = "番號"
.Cells(2, 2) = "file"
.Cells(2, 3) = "sheet"
.Cells(2, 4) = "cell"
.Cells(2, 5) = "內容"
.Cells(2, 6) = "檢索關鍵字"
.Cells(2, 1).Interior.ColorIndex = 4
.Cells(2, 2).Interior.ColorIndex = 4
.Cells(2, 3).Interior.ColorIndex = 4
.Cells(2, 4).Interior.ColorIndex = 4
.Cells(2, 5).Interior.ColorIndex = 4
.Cells(2, 6).Interior.ColorIndex = 4
If Dic.Count > 0 Then
Arr = Dic.keys
For N = LBound(Arr) To UBound(Arr)
.Cells(N + 3, 1) = N + 1
.Cells(N + 3, 2).Resize(1, 5) = Split(Arr(N), vbTab)
Next N
.[a3].Resize(N, 6).Borders.LineStyle = 1
Else
.Cells(3, 1) = "檢索內容沒有被找到"
End If
End With
MsgBox ("over" & vbCrLf & no1)
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/128889.html
標籤：VBA
下一篇：VBA解鎖VBA 工程保護