CODEWITHSUNDEEP
excelvbadynamicrange
igornachov
igornachov

Reputation: 21

Dynamic Range Naming for many columns at a time

I have a Sheet containing the US States in the top row which I am expecting each to be the name of a range. Of course, each State has a unique number of cities under its own name.

I want to create quickly and easily those range names (dynamic ranges) without using the "Create from List" option where a State with only 30 cities will show 80 or more blanks... (let's say Column 1 thru 50, Rows 1 thru 100, where 100 is the row where the State with more cities will end)

Not sure if I am clear but any help will be appreciated

Upvotes: 0

Views: 278

Answers (2)

Doug Glancy
Doug Glancy

Reputation: 27478

I've got some code I used to use a lot (it even had a user interface). It creates dynamic named ranges for every cell with content in row 1 of the ActiveSheet. It prepends "rng" to the contents of the cell to form the name, and also checks for illegal characters. These and spaces are replaced with an underscore:

Sub AddDynamicNamedRanges()
Dim ws As Excel.Worksheet
Dim rngColumns As Excel.Range
Dim LastCol As Long
Dim cell As Excel.Range
Dim Prefix As String
Dim IllegalCharReplacement As String
Dim RangeName As String

Set ws = ActiveSheet
Prefix = "rng"
IllegalCharReplacement = "_"
With ws
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    Set rngColumns = .Range(.Cells(1, 1), .Cells(1, LastCol))
    For Each cell In rngColumns
        If Not IsEmpty(cell) Then
            RangeName = GetCleanedName(Prefix & cell.Text, IllegalCharReplacement, True)
            .Names.Add Name:=RangeName, RefersTo:= _
                       "=Index(" & cell.EntireColumn.Address & "," & 2 & "):Index(" & cell.EntireColumn.Address & ",Max(" & 2 & ",COUNTA(" & cell.EntireColumn.Address & ")))"
        End If
    Next cell
End With
End Sub

Function GetCleanedName(ObjectName As String, Optional CharReplacement As String = "_", Optional Truncate As Boolean = True) As String
Dim NewName As String
Dim IllegalChars As String
Dim MaxLength As Long

'the "\" character escapes the Regex "reserved" characters
'x22 is double-quote
IllegalChars = "\||\^|\\|\x22|\(|\)|\[|]|\$|{|}|\-|/|`|~|!|@|#|%|&|=|;|:|<|>| "
'255 is the length limit for a legal name
MaxLength = 255
NewName = Regex_Replace(ObjectName, IllegalChars, CharReplacement, False)
If Truncate Then
    NewName = Left(NewName, MaxLength)
End If

GetCleanedName = NewName

End Function

Function Regex_Replace(strOriginal As String, strPattern As String, strReplacement, varIgnoreCase As Boolean) As String
' Function matches pattern, returns true or false
' varIgnoreCase must be TRUE (match is case insensitive) or FALSE (match is case sensitive)
' Use this string to replace double-quoted substrings - """[^""\r\n]*"""

Dim objRegExp As Object

Set objRegExp = CreateObject("Vbscript.Regexp")
With objRegExp
    .Pattern = strPattern
    .IgnoreCase = varIgnoreCase
    .Global = True
End With

Regex_Replace = objRegExp.Replace(strOriginal, strReplacement)

Set objRegExp = Nothing
End Function

Upvotes: 0

Andy G
Andy G

Reputation: 19367

While I certainly agree with @LaymanCoder that some coding-effort should be shown, I wanted to post the following as it will likely be useful to others.

Sub NameJaggedColumns()
    Dim rngTable As Range
    Dim iLastRow As Integer
    Dim rng As Range

    Set rngTable = Range("A1").CurrentRegion
    iLastRow = rngTable.Rows.Count
    For Each rng In rngTable.Columns
        Range(rng.Range("A2"), rng.Cells(iLastRow + 1).End(xlUp)) _
            .Name = rng.Range("A1")
    Next rng
End Sub

The OP will need to make some effort to understand and adapt it.

Upvotes: 1

Related Questions