試試這個：

Sub SelectAllRowsContainingKeyword(strKeyword As String)

Dim oRangeCombined As Range

Dim oRangeFound As Range

Dim strFirstAddress As String

Set oRangeFound = Cells.Find(strKeyword)

If Not oRangeFound Is Nothing Then

Set oRangeCombined = oRangeFound

strFirstAddress = oRangeFound.Address

Do

Set oRangeCombined = Union(oRangeCombined, oRangeFound)

Set oRangeFound = Cells.FindNext(oRangeFound)

Loop While Not oRangeFound Is Nothing And oRangeFound.Address <> strFirstAddress

End If

If Not oRangeCombined Is Nothing Then

oRangeCombined.EntireRow.Select

End If

End Sub

呼叫時傳入關鍵字即可，如：

Sub MyMacro

SelectAllRowsContainingKeyword "要查詢的關鍵字"

End Sub