问需要在Excel中执行动态范围

EN

Option Explicit

Sub PrintRectangleAddress()
    
    Const FirstRangeAddress As String = "B2:H1000"
    Const srNum As Long = 2
    Const ByColumn As Boolean = False

    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim frg As Range: Set frg = ws.Range(FirstRangeAddress)

    Dim rg As Range
    Set rg = RefRectangle(frg, srNum, ByColumn)
    
    If rg Is Nothing Then
        Debug.Print "Something went wrong."
        Exit Sub
    End If
    
    Debug.Print rg.Address(0, 0)

End Sub

Sub PrintConsecutiveRectangleAddresses()
    
    Const FirstRangeAddress As String = "B2:H1000" ' "A1:ZZ10000"
    Const ByColumn As Boolean = False ' True
    Const nCount As Long = 40
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim frg As Range: Set frg = ws.Range(FirstRangeAddress)

    Dim rg As Range
    Dim n As Long
    
    For n = 1 To nCount ' Step 3
        Set rg = RefRectangle(frg, n, ByColumn)
        If rg Is Nothing Then
            Debug.Print "Something went wrong."
            Exit Sub
        Else
            Debug.Print rg.Address(0, 0)
        End If
    Next n

End Sub

Function RefRectangle( _
    ByVal FirstRange As Range, _
    ByVal SubRangeIndex As Long, _
    Optional ByVal ByColumn As Boolean = False) _
As Range
    Const ProcTitle As String = "Reference Rectangle"
    
    If FirstRange Is Nothing Then Exit Function
    
    Dim trg As Range
    Dim rCount As Long
    Dim cCount As Long
    
    With FirstRange
        rCount = .Rows.Count
        cCount = .Columns.Count
       ' Exclude top and left
        Set trg = .Resize(.Worksheet.Rows.Count - .Row + 1, _
                .Worksheet.Columns.Count - .Column + 1)
    End With
    'Debug.Print trg.Address
    
    Dim srrCount As Long: srrCount = Int(trg.Rows.Count / rCount)
    Dim srcCount As Long: srcCount = Int(trg.Columns.Count / cCount)
    Dim srMax As Long: srMax = srrCount * srcCount
    'Debug.Print srrCount, srcCount, srMax
    
    If SubRangeIndex > srMax Then
        MsgBox "There is only " & srMax & " ranges.", vbCritical, ProcTitle
        Exit Function '
    End If
    
    Dim srrOffset As Long
    Dim srcOffset As Long
    
    If ByColumn Then
        srrOffset = ((SubRangeIndex - 1) Mod srrCount) * rCount
        srcOffset = Int((SubRangeIndex - 1) / srrCount) * cCount
    Else
        srrOffset = Int((SubRangeIndex - 1) / srcCount) * rCount
        srcOffset = ((SubRangeIndex - 1) Mod srcCount) * cCount
    End If
    'Debug.Print srrOffset, srcOffset
    
    With FirstRange
        Set RefRectangle = .Offset(srrOffset, srcOffset).Resize(rCount, cCount)
    End With
    
End Function

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sCell As Range: Set sCell = Range("A1")
    If Not Intersect(sCell, Target) Is Nothing Then
        If IsNumeric(sCell.Value) Then
            Dim rg As Range
            Set rg = RefRectangle(Range("B2:H1000"), CLng(sCell.Value))
            If Not rg Is Nothing Then
                rg.Select ' or do something more useful
            End If
        End If
    End If
End Sub