以前はよく使っていたコードがいくつかあります (ユーザー インターフェイスもありました)。の行 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