0

我在第一行有一张包含美国各州的表格，我希望每个表格都是一个范围的名称。当然，每个州都有自己名称下的唯一数量的城市。

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

不确定我是否清楚，但任何帮助将不胜感激

4

2 回答 2

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 将需要做出一些努力来理解和适应它。

于 2013-06-26T21:42:03.987 回答
0

我有一些我经常使用的代码（它甚至有一个用户界面）。它为每个单元格创建动态命名范围，内容位于ActiveSheet. 它将“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
于 2013-06-27T01:19:24.773 回答