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
Bookmarks