Sub Macro1()
Dim arr(), c As Range, firstAddress$, sh As Worksheet, s$, m&
s = Application.InputBox("请输入查找内容", "请输入", Type:=2)
If s = "" Then Exit Sub
For Each sh In Sheets
If sh.Name <> "result" Then
With sh.UsedRange
Set c = .Find(s, , , xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
m = m + 1
ReDim Preserve arr(1 To 3, 1 To m)
arr(1, m) = sh.Name
arr(2, m) = c.Address(0, 0)
arr(3, m) = c.Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End If
Next
ActiveSheet.UsedRange.ClearContents
If m > 0 Then
[a1].Resize(m, 3) = WorksheetFunction.Transpose(arr)
With ActiveSheet
For i = 1 To m
.Hyperlinks.Add Anchor:=.Cells(i, 3), Address:="", SubAddress:=arr(1, i) & "!" & arr(2, i), TextToDisplay:=arr(3, i)
Next
End With
End If
End Sub
