Try this:
Option Explicit
Sub SearchAreas()
Dim FirstAddress As String
Dim c As Range
Dim Rng1 As Range
Dim SelectedRange As Range
Dim MyResponse As VbMsgBoxResult
With ActiveSheet.Cells
Set c = .Find(What:="*", LookIn:=xlValues)
If c Is Nothing Then
MsgBox "The worksheet is empty", vbInformation, "Blank Worksheet"
Exit Sub
End If
c.CurrentRegion.Select
MyResponse = MsgBox("Is this the current region?", _
vbQuestion + vbYesNo, "Current Region")
If MyResponse = vbYes Then
Set SelectedRange = Selection
GoTo Completed:
End If
FirstAddress = c.Address
Set Rng1 = Selection
Do
If Intersect(Rng1, Selection) Is Nothing Then
MyResponse = MsgBox("Is this the current region?", _
vbQuestion + vbYesNo, "Current Region")
If MyResponse = vbYes Then
Set SelectedRange = Selection
GoTo Completed:
End If
End If
If Rng1 Is Nothing Then
Set Rng1 = Selection
Else
Set Rng1 = Union(Rng1, Selection)
End If
Set c = .FindNext(c)
c.CurrentRegion.Select
Loop While Not c Is Nothing And c.Address <> FirstAddress
End With
Completed:
If MyResponse = vbYes Then
MsgBox "You selected range " & SelectedRange.Address, _
vbInformation, "Range Selected"
Else
MsgBox "You did not select a range", vbInformation, "No Range Selected"
End If
End Sub