Attribute VB_Name = "sub_CreateNamedRanges" Option Explicit
Sub CreateNames() 'see end of file for information under ProcedureFooter Dim wb As Workbook, ws As Worksheet Dim Lrow As Long, lcol As Long, i As Long Dim myName As String, Start As String
' set the row number where headings are held as a constant
' change this to the row number required if not row 1
Const Rowno = 1
' set the Offset as the number of rows below Rowno, where the
' data begins
Const ROffset = 1
' set the starting column for the data, in this case 1
' change if the data does not start in column A
Const Colno = 1
' Set an Offset from the starting column, for the column number that
' will always have data entered, and will therefore be used in calculating lrow
Const COffset = 0 ' in this case, the first column will always contain data.
On Error GoTo CreateNames_Error
Set wb = ActiveWorkbook
Set ws = ActiveSheet
' count the number of columns used in the row designated to
' have the header names
lcol = Cells(Rowno, Columns.Count).End(xlToLeft).Column
Lrow = ws.Cells(Rows.Count, Colno).End(xlUp).Row
Start = Cells(Rowno, Colno).Address
CreateName: Dim tabPrefix As String If Err.Number = 1004 Then Let tabPrefix = InputBox("What prefix do you want to add to the name of this range?" & vbCrLf & _ "This is typically the name of the worksheet tab is the best choice." & vbCrLf & _ "In this tab the name is already in the InputBox below.", "Tab Prefix", ws.Name) Else tabPrefix = ws.Name End If
wb.Names.Add Name:=tabPrefix & "_lcol", RefersTo:="=COUNTA($" & Rowno & ":$" & Rowno & ")"
wb.Names.Add Name:=tabPrefix & "_lrow", RefersToR1C1:="=COUNTA(C" & Colno + COffset & ")"
wb.Names.Add Name:=tabPrefix & "_myData", RefersTo:= _
"=" & Start & ":INDEX($1:$65536," & tabPrefix & "_lrow," & tabPrefix & "_Lcol)"
For i = Colno To lcol
' if a column header contains spaces, replace the space with an underscore
' spaces are not allowed in range names.
myName = tabPrefix & "_" & Replace(Cells(Rowno, i).Value, " ", "_")
If myName = "" Then
' if column header is blank, warn the user and stop the macro at that point
' names will only be created for those cells with text in them.
MsgBox "Missing Name in column " & i & vbCrLf _
& "Please Enter a Name and run macro again"
Exit Sub
End If
wb.Names.Add Name:=myName, RefersToR1C1:= _
"=R" & Rowno + ROffset & "C" & i & ":INDEX(C" & i & "," & tabPrefix & "_lrow)"
nexti: Next i
On Error GoTo 0
MsgBox "All dynamic Named ranges have been created"
Exit Sub
Exit Sub
CreateNames_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & _ ") in procedure CreateNames of Module Technology4U" If Err.Number <> 0 Then GoTo CreateName ProcedureFooter: ''=========================================================================================== '' Procedure: ......... sub_CreateNamedRanges.bas/CreateNames '' Description: ....... creates names in name manager based on columns '' Version: ........... 1.0.0 - major.minor.patch '' Created: ........... 2016-05-16 '' Updated: ........... 2022-09-08 '' Module URL: ........ weburl '' Installs to: ....... vba-files/Module '' Compatibility: ..... Excel '' Contact Author: .... modified by lundeen-bryan, originally by Roger Govier, Technology4U '' Copyright: ........ n/a ©2022. All rights reserved. '' Called by: ......... other_subs '' Calls to: .......... other_subs '' Parameters: ........ parameters '' Return: ............ type param_description '' Notes: ............. _ (1) notes_here ''=========================================================================================== End Sub