Круговой выбор диапазона

Question

Есть ли простой способ создать диапазон, который не является прямоугольником, а кругом по центру ActiveCell? Я мог бы просто определять каждую строку по одному, но я надеюсь, что кто-то здесь знает более изящное решение.

Диапазон круга

Обновление:

Вот решение, на котором я остановился, благодаря помощи JvDV:

Sub revealMap(playerLocation As Range, sightDistance As Integer)
Dim search As Range, cl As Range
Dim stcol As Integer, strow As Integer
Dim endrow As Integer: endrow = 1 + sightDistance * 2
Dim endcol As Integer: endcol = 1 + sightDistance * 2

If playerLocation.row - sightDistance < 0 Then
    strow = 1
    endrow = endrow - playerLocation.row
Else
    strow = playerLocation.row - sightDistance
End If
If playerLocation.Column - sightDistance < 0 Then
    stcol = 1
    endcol = endcol - playerLocation.col
Else
    stcol = playerLocation.Column - sightDistance
End If
Set search = ActiveSheet.Cells(strow, stcol)

For Each cl In search.Resize(endrow, endcol)
    If (Sqr((Abs(cl.row - playerLocation.row)) ^ 2 + (Abs(cl.Column - playerLocation.Column)) ^ 2) <= sightDistance) And (cl.Interior.ColorIndex = 1) Then
        Worksheets("Map Ref").Cells(cl.row, cl.Column).Copy (Worksheets("World Map").Cells(cl.row, cl.Column))
    End If
Next cl
End Sub

Answer 1

Просто для удовольствия. Что касается @BigBen, вам понадобится какой-то тип логики c. Так, например, пример для случая с бриллиантом:

Sub Test()

Dim rng1 As Range, rng2 As Range: Set rng1 = ActiveCell

For Each cl In ActiveCell.Offset(-3, -3).Resize(7, 7)
    If Abs(cl.Row - rng1.Row) + Abs(cl.Column - rng1.Column) <= 3 Then
        If Not rng2 Is Nothing Then
            Set rng2 = Union(rng2, cl)
        Else
            Set rng2 = Union(rng1, cl)
        End If
        Debug.Print rng2.Address
    End If
Next cl

rng2.Select

End Sub

Так же, как @Galimi, я не учел крайние случаи.

Удачи.

Answer 2

Нечто подобное должно работать. (Это просто мини-бриллиант, но вы поняли идею)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

'select all the cells surrounding the current cell
Application.EnableEvents = False

strRange = Target.Offset(0, 1).Address & "," & Target.Offset(1).Address & "," & Target.Offset(0, -1).Address & "," & _
            Target.Offset(-1).Address & "," & Target.Address

Range(strRange).Select
Target.Activate
Application.EnableEvents = True

End Sub

Обязательно поместите этот код в объект ThisWorkbook.