Excel VBA: Dynamic Named Ranges Based on ActiveCell Address

Question

I am attempting to create a dynamic named range that is dependent on the current ActiveCell. The data set has two strokes (Extend/Retract), and each stroke has a unique data sample rate, so the height fluctuates for every stroke and resets at 1 indicating the beginning of a new stroke. The last column of the data set has a token indicating direction traveled at the end of each row (see pic).

The idea was to wrap the code in a Spin Button (ActiveX Control) and allow the user to scroll up or down the data set charting only the data relevant to that cycle.

I have been able to extract the ActiveCell.Address and store it in a cell on the sheet, but using it as a reference in an Offset was nonviable since it's a string.

ws1.Range("AI1").Value = ActiveCell.Address

Alternatively, I extracted the current ActiveCell.Row (data begins at row 8) to determine the height of the `Offset' (needn't worry about columns, they are constant)

ws1.Range("AI2").Value = ActiveCell.Row - 7

While this does work for the first set, the named range grows to include the next stroke and the previous stroke. This needs to be subtracted off...

In a different approach, I used a recorded Macro to simulate highlighting the blank rows between the used rows. This does offer a correct count, but I am unsure how to exploit this...

Range(Selection, Selection.End(xlDown)).Select

In short, I would like to to count the number of blank cells between the text in the T column simulating ctrldwn and create a named range that references the ActiveCell.address as the starting point and the number of cells between text.

Any alternative approaches or suggestions will be met with gratitude.

Answer 1

To put it mildly, I haven't been very good at understanding your picture. So, on another approach, I tried to find a way to exploit the solution you already found but failed to find the end toward which it surely could be exploited.

Basically, one wouldn't store anything on the sheet that isn't supposed to be saved. Any number of any type of variable can be stored in memory. It will be lost when Excel is shut down or the program comes to an end.

Dim aCell As Range
Set aCell = Activecell

This code will create a variable of Range datatype to which it then assigns the the ActiveCell object which will remain unchanged even if the ActiveCell changes. You can use aCell in any way you might use ActiveCell, such as

Debug.Print aCell.Address, aCell.Row
Set MyRange = Range(aCell, aCell.Offset(17))

Observe that you can always create a range object if you have an address. Set MyCell = ActiveSheet.Range("A3") creates such an object and aCell.Value = MyCell.Address reverses the process. Use the Set word to assign an object, not required for strings or numbers.

Selection is a range object. Therefore it has all the properties of a range.

Dim sRange As Range
Set sRange = Selection
Debug.Print sRange.Address(0, 0)
Set sRange = sRange.Resize(15)
Debug.Print sRange.Address, sRange.Worksheet.Name

I hope this will let you move up one step.

Answer 2

Scroll By Criteria

• Adjust the constants in the sheet module if necessary.
• I successfully tested the code with two command buttons, but I couldn't get it to work properly with the SpinUp and SpinDown events of the spin button (often it runs the procedures twice, like it has been clicked twice).
• I think it has something to do with focus. While at it, a good idea is to set TakeFocusOnClick in the command buttons to False
• The Select Case statements should be self explanatory.

The If Statements

• When Up is 'used', then at the intersection of one row above the ActiveCell's row and the criteria column, it checks if the value is equal to criteria. If so, searching up starting from the cell above, tries to find the criteria. If found, scrolls to one row below the found cell and activates the cell in the initially saved column of the ActiveCell in it. If criteria is not found, it scrolls to the cell defined by the sixth (The header is in the fifth row and five rows are frozen) row and the initially saved column of the ActiveCell.
• When Down is 'used', then at the intersection of one row below the ActiveCell's row and the criteria column, it checks if the value is equal to criteria. If so, searching down starting from the cell below, tries to find the criteria. If found, scrolls to one row below the found cell and activates the cell in the initially saved column of the ActiveCell in it. If criteria is not found, it tries to find the criteria searching from the cell one row below to the bottom of the column. If found, , scrolls to one row below the found cell and activates the cell in the initially saved column of the ActiveCell in it. Otherwise exits the procedure.

The Flow

• The command buttons are 'calling' the procedures DirUp or DirDown, which are calling the changeDirection procedure which when necessary calls the defineFoundCell procedure.

Standard Module e.g. Module1

Option Explicit

Sub changeDirection(ByVal Criteria As String, _
                    Optional ByVal ignoreCase As Boolean = False, _
                    Optional ByVal ColumnIndex As Variant = 1, _
                    Optional ByVal FirstRow As Long = 1, _
                    Optional ByVal goUp As Boolean = False, _
                    Optional Sheet As Worksheet = Nothing)

    ' Initialize error handling.
    Const ProcName = "changeDirections"
    On Error GoTo clearError ' Turn on error trapping.

    If Sheet Is Nothing Then
        Set Sheet = ActiveSheet
    End If
    
    Dim cel As Range
    Set cel = Sheet.Cells(ActiveCell.Row, ColumnIndex)
    
    Dim ActiveColumnNumber As Long
    ActiveColumnNumber = ActiveCell.Column
    
    Dim rng As Range
    Dim ScrollToRow As Long
    
    If goUp Then
        
        Select Case cel.Row
            Case Is < FirstRow ' 'ActiveCell' is above 'FirstRow'.
                GoTo ProcExit
            Case Is = FirstRow ' 'Activecell' is in 'FirstRow'.
                GoTo ProcExit
            Case Else ' 'ActiveCell' is below 'FirstRow'. Continue...
        End Select
        
        If cel.Offset(-1).Value = Criteria Then
            defineFoundCell rng, cel.Offset(-2), Criteria, ignoreCase, _
                            False, FirstRow
        Else ' cel.Offset(-1).Value <> Criteria
            defineFoundCell rng, cel.Offset(-1), Criteria, ignoreCase, _
                            False, FirstRow
        End If
        
        If rng Is Nothing Then
            ScrollToRow = FirstRow
        Else
            ScrollToRow = rng.Row + 1
        End If
    
    Else ' (goDown)
        
        Select Case cel.Row
            Case Is < FirstRow ' 'ActiveCell' is above 'FirstRow'.
                ScrollToRow = FirstRow
                GoTo selectCellRange
            Case Is = FirstRow ' 'Activecell' is in 'FirstRow'. Continue...
            Case Else ' 'ActiveCell' is below 'FirstRow'. Continue...
        End Select
        
        If cel.Offset(1).Value = Criteria Then
            ScrollToRow = cel.Row + 2
        Else
            defineFoundCell rng, cel.Offset(1), Criteria, ignoreCase, _
                            True, FirstRow
            If rng Is Nothing Then
                GoTo ProcExit
            Else
                ScrollToRow = rng.Row + 1
            End If
        End If
    End If
    
selectCellRange:
    Sheet.Cells(ScrollToRow, ActiveColumnNumber).Activate
    ActiveWindow.ScrollRow = ScrollToRow

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

End Sub

Sub defineFoundCell(ByRef FindCellRange As Range, _
                    InitialCellRange As Range, _
                    ByVal Criteria As String, _
                    Optional ByVal ignoreCase As Boolean = False, _
                    Optional ByVal getAfterInitialCell As Boolean = False, _
                    Optional ByVal FirstRow As Long = 1, _
                    Optional ByVal ColumnIndex As Variant = 1)

    ' Initialize error handling.
    Const ProcName = "defineFoundCell"
    On Error GoTo clearError ' Turn on error trapping.
    
    Set FindCellRange = Nothing
    
    Dim ws As Worksheet: Set ws = InitialCellRange.Worksheet
    Dim FirstCell As Range
    Dim LastCell As Range
    If getAfterInitialCell Then
        Set FirstCell = InitialCellRange
        Set LastCell = ws.Cells(ws.Rows.Count, ColumnIndex)
        Set FindCellRange = ws.Range(FirstCell, LastCell) _
                              .Find(What:=Criteria, _
                                    After:=LastCell, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    MatchCase:=Not ignoreCase)
    Else ' getAfterInitialCell = False
        Set FirstCell = ws.Cells(FirstRow, ColumnIndex)
        Set LastCell = InitialCellRange
        Set FindCellRange = ws.Range(FirstCell, LastCell) _
                              .Find(What:=Criteria, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    SearchDirection:=xlPrevious, _
                                    MatchCase:=Not ignoreCase)
    End If

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': " & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    On Error GoTo 0 ' Turn off error trapping.
    GoTo ProcExit

End Sub

Sheet Module e.g. Sheet1

Option Explicit

Private Const Criteria As String = "Extend"
Private Const CriteriaColumnID As Variant = "T" ' or 20
Private Const FirstRow As Long = 6

Sub DirUp()
    changeDirection Criteria, , CriteriaColumnID, FirstRow, True, Me
End Sub

Sub DirDown()
    changeDirection Criteria, , CriteriaColumnID, FirstRow, , Me
End Sub

Private Sub CommandButton1_Click()
    DirUp
End Sub
Private Sub CommandButton2_Click()
    DirDown
End Sub

Private Sub SpinButton1_SpinUp()
    DirUp
End Sub
Private Sub SpinButton1_SpinDown()
    DirDown
End Sub

Answer 3

Assuming there is a SpinButton1 in the sheet, i've created this code:

Private Sub SubSpin()
    
    'Declaring variables.
    Dim RngTop As Range
    Dim IntCounter01 As Integer
    Dim RngBottom As Range
    Dim StrName As String
    
    'Setting variable.
    StrName = "Section"
    
    'Resetting the SpinButton1 maximum value.
    SpinButton1.Max = Cells.Rows.Count
    
    'Checkpoint.
RestartLoop1:
    
    'Setting variables.
    Set RngTop = Range("T8")
    Set RngBottom = RngTop.End(xlDown)
    
    'Using a Do-Loop cycle to cover the entire list.
    Do Until IntCounter01 >= SpinButton1.Value
        
        'Checking if the code is about to pass the last row of the sheet.
        If RngTop.End(xlDown).Row = Cells.Rows.Count Then
                
                'Setting the maximum value of SpinButton1.
                SpinButton1.Max = SpinButton1.Value - 1
                
                'Quitting the loop.
                GoTo ExitLoop1
                
        End If
        
        'Setting variables.
        Set RngTop = RngTop.End(xlDown).Offset(1, 0)
        Set RngBottom = RngTop.End(xlDown)
        IntCounter01 = IntCounter01 + 1
    
    Loop
    
    'Checkpoint.
ExitLoop1:
    
    'Naming the found range.
    ActiveWorkbook.Names.Add Name:=StrName, RefersToR1C1:="=Foglio1!R" & RngTop.Row & "C20:R" & RngBottom.Row & "C20"
    
    'Checking if the range is empty.
    If Excel.WorksheetFunction.CountBlank(Range(StrName)) = Range(StrName).Cells.Count Then
            'Setting variables to select the previous range.
            IntCounter01 = 0
            SpinButton1.Value = SpinButton1.Value - 1
            'Restarting the loop.
            GoTo RestartLoop1
    End If
    
    'Setting variables.
    Range("AI1").Value = SpinButton1.Value
    Range("AI2").Value = Range(StrName).Address
    
End Sub

Private Sub SpinButton1_SpinDown()
    Call SubSpin
End Sub
Private Sub SpinButton1_SpinUp()
    Call SubSpin
End Sub

It creates a name referred to the section "selected" via the spinbutton. It also prints in cell AI1 the current value of SpinButton1 while in cell AI2 it prints the given range. The code prevents the selection of a blank section and the overshooting of the last cell in the sheet. The spinbutton has a minimum value of 0. I'd sugget to set its SmallChange property to -1 to make it more intuitive for the user.