Need to do a dynamic range in Excel

user_17354059 0
Viewed 59

I'm stuck in a problem with my code. I did a automatic counter so every time I click forward it counts +1 and backwards-1. So now depending on which number is placing on cell number A2 I want to do a Select.Range function.

If A2= 1 select cells from B2:H1000
If A2 = 2 select cells from I2:O1000 and so go on.

If I could put a mathematical equation on Range function it will be like: Select.Range("(n*7-5)1:(n*7+1)1000") n being A2 cell value. But I think it will be not possible to put equations as variables in this function.

How can I solve this?

vba excel
1 Answers

Reference a Rectangle

  • Adjust (play with) the values in the constants sections.

Standard Module e.g. Module1

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

Sheet Module e.g. Sheet1

  • Now that you have played with the code and understood how it works you could utilize the function in your actual case. A simplified version (no disabling events and no error handling) would be something like the following:
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
  • Now this is fully automated: as you change the value in A1, another range becomes selected.
user_98140690
Related