0

一番上の行に米国の州を含むシートがあり、それぞれが範囲の名前であると予想しています。もちろん、各州には、独自の名前を持つ独自の数の都市があります。

30 都市しかない州に 80 以上の空白が表示される [リストから作成] オプションを使用せずに、これらの範囲名 (動的範囲) をすばやく簡単に作成したいと考えています... (列 1 から 50、行 1 から 50 としましょう) 100、ここで 100 はより多くの都市を持つ州が終了する行です)

私が明確かどうかはわかりませんが、助けていただければ幸いです

4

2 に答える 2

0

以前はよく使っていたコードがいくつかあります (ユーザー インターフェイスもありました)。の行 1 のコンテンツを含むすべてのセルに対して動的な名前付き範囲を作成します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 に答える