动态范围一次为许多列命名

Question

我有一张包含美国国家在最上面的行，我期望每个都是一个范围的名称。当然，每个国家都有自己名下的独特城市数量。

我想在不使用“从列表创建”选项的情况下快速轻松地创建这些范围名称（动态范围），其中只有30个城市的州将显示80个或更多空白...（比方说第1列至第50列，行1通100，其中100是其中具有更多的城市，国家将结束行）

不知道如果我很清楚，但任何帮助将不胜感激

Answer 1

虽然我当然@LaymanCoder一些编码一致应该显示，我想发布以下内容，因为它可能对其他人有用。

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 

OP将需要做出一些努力来理解和适应它。

Answer 2

我有一些代码，我曾经使用了很多（它甚至有一个用户界面）。它为ActiveSheet的第1行中的每个单元格创建动态命名范围。它预先对单元格的内容“rng”形成名称，并检查非法字符。这些和空格替换为下划线：

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