On Error Resume Next
Dim PH As String, Name1 As String, Name2 As String, S As String
Dim ob1 As Object, Wb As Workbook
Dim G As Integer, N As Integer, N1 As Integer
PH = InputBox("請輸入要查找字符的文件夾:", "提示信息", "d:\my")
S = InputBox("請輸入要查找的字符:", "提示信息")
PH = IIf(Right(PH, 1) = "\", PH, PH & "\")
Name2 = Dir(PH & "*.xls")
Name1 = ActiveWorkbook.Name
Stop
Do While Name2 <> "" And S <> ""
If Name1 <> Name2 Then
Set Wb = Workbooks.Open(PH & "\" & Name2)
N = N + 1
For G = 1 To Sheets.Count
Sheets(G).Activate
For Each ob1 In ActiveSheet.UsedRange
If InStr(ob1.Value, S) > 0 Then N1 = N1 + 1: ob1.Select: GoTo w1
Next ob1
Next G
Wb.Close
End If
w1: Name2 = Dir
Loop
MsgBox ("在“" & PH & "”文件夾中***查找了 " & N & " 個Excel文件，" & Chr(13) & "文件內容中有“" & S & "”的文件有 " & N1 & " 個。")
Workbooks(Name1).Close
End Sub
以上程序能滿足妳的要求