Skip to content

Instantly share code, notes, and snippets.

@stephlocke
Created January 13, 2015 10:32
Show Gist options
  • Save stephlocke/411ef25f5fa819b495be to your computer and use it in GitHub Desktop.
Save stephlocke/411ef25f5fa819b495be to your computer and use it in GitHub Desktop.
Dynamic named range generator
#Const LateBind = True
Function RegExpSubstitute(ReplaceIn, _
ReplaceWhat As String, ReplaceWith As String)
#If Not LateBind Then
Dim RE As RegExp
Set RE = New RegExp
#Else
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
#End If
RE.Pattern = ReplaceWhat
RE.Global = True
RegExpSubstitute = RE.Replace(ReplaceIn, ReplaceWith)
End Function
Sub createRanges()
' Specify some upfront variables
rCol = ActiveSheet.UsedRange.Columns(1).Column
rRow = ActiveSheet.UsedRange.Rows(1).Row
sName = "'" & ActiveSheet.Name & "'!"
' This is where the row count gets multiplied to allow for growth
LastRow = (ActiveSheet.UsedRange.Rows.Count - 1) * 10
LastColumn = ActiveSheet.UsedRange.Columns.Count
' Build a cleansed sheetname for use in naming the raw data tables
sheetname = ActiveSheet.Name
sheetname = RegExpSubstitute(sheetname, "[^\w+]", "")
sheetname = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(sheetname, "0", "a"), "1", "b"), "2", "c"), "3", "d"), "4", "e"), "5", "f"), "6", "g")
, "7", "h"), "8", "i"), "9", "j"), "|", "")
' Build the headered raw data range
ActiveWorkbook.Names.Add Name:=sheetname, _
RefersTo:="=Offset(" & sName & Cells(rRow, rCol).Address & ",0,0,counta(" _
& sName & Cells(rRow, rCol).Address & ":" & Cells(LastRow, rCol).Address _
& "),counta(" & sName & Cells(rRow, rCol).Address & ":" & Cells(rRow, LastColumn * 3).Address & "))"
' Build the headerless raw data range
ActiveWorkbook.Names.Add Name:=sheetname & "HEADERLESS", _
RefersTo:="=Offset(" & sName & Cells(rRow + 1, rCol).Address & ",0,0,counta(" _
& sName & Cells(rRow + 1, rCol).Address & ":" & Cells(LastRow, rCol).Address _
& "),counta(" & sName & Cells(rRow, rCol).Address & ":" & Cells(rRow, LastColumn * 3).Address & "))"
' Create individual columns ranges
While rCol <= LastColumn
rangeName = Replace(Cells(rRow, rCol).Value, " ", "")
rangeName = RegExpSubstitute(rangeName, "[^\w+]", "")
rangeName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(rangeName, "0", "a"), "1", "b"), "2", "c"), "3", "d"), "4", "e"), "5", "f"), "6", "g")
, "7", "h"), "8", "i"), "9", "j"), "|", "")
ActiveWorkbook.Names.Add Name:=rangeName, _
RefersTo:="=Offset(" & sName & Cells(rRow + 1, rCol).Address & ",0,0,counta(" & sName & Cells(rRow + 1, ActiveSheet.UsedRange.Columns(1).Column).Address & ":" & Cells(LastRow, ActiveSheet.UsedRange.Columns(1).Column).Address & "))"
rCol = rCol + 1
Wend
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment