Findを使ったらFindNextで次々と検索できる。
以前見つかったセルと同じセルが見つかったりしないかだけはチェック必要。
Sub Sample6() Dim FoundCell As Range, FirstCell As Range, Target As Range Set FoundCell = Cells.Find(What:="田中") If FoundCell Is Nothing Then MsgBox "見つかりません" Exit Sub Else Set FirstCell = FoundCell Set Target = FoundCell End If Do Set FoundCell = Cells.FindNext(FoundCell) If FoundCell.Address = FirstCell.Address Then Exit Do Else Set Target = Union(Target, FoundCell) End If Loop Target.Select MsgBox Target.Count & "件見つかりました" End Sub
ネタ元