Snasui Excel Forum

Code: Select all

Sub CreateNames()


    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
    
    wb.Names.Add Name:="lcol", RefersTo:="=COUNTA($" & Rowno & ":$" & Rowno & ")"
    wb.Names.Add Name:="lrow", RefersToR1C1:="=COUNTA(C" & Colno + COffset & ")"
    wb.Names.Add Name:="myData", RefersTo:= _
                  "=" & Start & ":INDEX($1:$65536," & "lrow," & "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 = 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 & ",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"

End Sub

Code: Select all

myName = Replace(myName, "#", "")

Code: Select all

Option Explicit

Sub CreateNames()

    Dim wb As Workbook, ws As Worksheet
    Dim lrow As Long, lcol As Long, i As Long
    Dim myName As String, Start As String
    
    Const Rowno = 1
    Const ROffset = 1
    Const Colno = 1
    Const COffset = 0  ' in this case, the first column will always contain data.
    
    On Error GoTo CreateNames_Error
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
    lcol = Cells(Rowno, Columns.Count).End(xlToLeft).Column
    lrow = ws.Cells(Rows.Count, Colno).End(xlUp).Row
    Start = Cells(Rowno, Colno).Address
    wb.Names.Add Name:="lcol", RefersTo:="=COUNTA($" & Rowno & ":$" & Rowno & ")"
    wb.Names.Add Name:="lrow", RefersToR1C1:="=COUNTA(C" & Colno + COffset & ")"
    wb.Names.Add Name:="myData", RefersTo:= _
                  "=" & Start & ":INDEX($1:$65536," & "lrow," & "Lcol)"
                  
    For i = Colno To lcol
        myName = Replace(Cells(Rowno, i).Value, " ", "_")
        myName = Replace(myName, "#", "")
        If myName = "" Then
            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 & ",lrow)"
    Next i
    
    On Error GoTo 0
        MsgBox "All dynamic Named ranges have been created"
    Exit Sub
    
CreateNames_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & _
    ") in procedure CreateNames of Module Technology4U"
    
End Sub