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