Thread: Macro for Dynamic Ranges

I end up making dynamic ranges in most workbooks, and tire of typing then in. The code below allows you to select a range and it makes dynamic ranges using the header row, for numbers or text, according to the contents of the cell below the header.

       --B--- C --D---
   2   valNam   valNum
   3   Abel          5
   4   Bill          5
   5   Cain         34
   6   Drew         38
   7   Eric         74
   8   Fred         76
   9   Gary           
  10   Hank           
  11   Ivan

Here 'tis, hope you find it useful.

Sub MakeDynRanges()
    ' shg 2011-06

    ' Adds dynamic ranges using the names in the top row of the selection
    Dim r           As Range
    Dim cell        As Range

    If Not TypeOf Selection Is Range Then
        MsgBox Prompt:="Select a range and try again.", _
               Title:="Oops!"
        Exit Sub
    End If

    ActiveWorkbook.Names.Add Name:="conBig", RefersTo:=9.99999999999999E+307
    ActiveWorkbook.Names.Add Name:="conZzz", RefersTo:="=rept(""z"", 255)"
    
    Set r = Selection

    For Each cell In Intersect(r.Rows(1).EntireRow, r.EntireColumn).Cells
        If Len(cell.Text) Then
            MakeDynRange cell, VarType(cell.Offset(1).Value2)
        End If
    Next cell
End Sub

Function MakeDynRange(cell As Range, iType As VbVarType) As Boolean
    ' shg 2011-06
    Dim sName       As String
    Dim sAdrCel     As String
    Dim sAdrCol     As String

    With cell.Worksheet
        sName = Replace(Replace(cell.Text, " ", ""), Chr(160), "")
        sAdrCel = cell.Address
        sAdrCol = cell.EntireColumn.Address

        If IsValidRangeName(sName) Then
            Select Case iType
                Case vbDouble
                    .Names.Add _
                            Name:=sName, _
                            RefersTo:="=index(" & sAdrCol & ", row(" & sAdrCel & ") + 1):" & _
                                      "index(" & sAdrCol & ", match(conBig, " & sAdrCol & "))"
                    MakeDynRange = True
                
                Case vbString
                    .Names.Add _
                            Name:=sName, _
                            RefersTo:="=index(" & sAdrCol & ", row(" & sAdrCel & ") + 1):" & _
                                      "index(" & sAdrCol & ", match(conZzz, " & sAdrCol & "))"
                    MakeDynRange = True
                
                Case Else
                    Select Case InputBox(Prompt:="Data below cell " & cell.Address & " will be: " & vbLf & vbLf & _
                                                 "1. Numbers" & vbLf & _
                                                 "2. Text", _
                                         Title:="Dynamic Column Ranges")
                        Case "1"
                            MakeDynRange = MakeDynRange(cell, vbDouble)
                        Case "2"
                            MakeDynRange = MakeDynRange(cell, vbString)
                        Case Else
                            Exit Function
                    End Select
            End Select
        Else
            MsgBox Prompt:="""" & sName & """ in " & _
                           cell.Address(False, False) & _
                           " is not a valid name.", _
                   Title:="Oops"
        End If
    End With
End Function

Function IsValidRangeName(sInp As String) As Boolean
    ' shg 2011-06
    
    Dim sTest As String
    
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Pattern = "^[A-Z_][\w]{0,254}$"
        If Not .test(sInp) Then Exit Function
    End With
    
    ' verify that the name doesn't look like an A1 or R1C1 address
    On Error Resume Next
    With Application
        sTest = LCase(.ConvertFormula(sInp, xlA1, xlR1C1, True))
        If Err.Number = 0 Then
            If sTest <> LCase(sInp) Then Exit Function
        Else
            Err.Clear
        End If
        
        sTest = LCase(.ConvertFormula(sInp, xlR1C1, xlA1, True))
        If Err.Number = 0 Then
            If sTest <> LCase(sInp) Then Exit Function
        Else
            Err.Clear
        End If
    End With

    IsValidRangeName = True
End Function

I added a prompt to let the user select workbook or worksheet scope.