How can I rename each column of a table

Question

I want to give each column in a table with X columns its own name.

The string on A1 will be used to rename the first column, followed by the string on B1 for the second, and so on.

I tried using: ActiveWorkbook.Names.Add Name:=Name, RefersToR1C1:="=Sheet1!R2C1:R70C1"

But I want to replace the R2C1:R70C1 to something like R2CA:R70CA where A's value goes up for each column. And also replace Sheet1 with ActiveSheet.Name

Any suggestions?

Answer 1

Add Name For Each Column

Sub AddNames()
    
    Const FirstCol As String = "A"
    Const FirstRow As Long = 2
    Const LastRow As Long = 70
    
    With ActiveSheet

        Dim wsName As String: wsName = .Name

        Dim fCell As Range: Set fCell = .Cells(FirstRow, FirstCol)
        Dim rg As Range
        Set rg = .Range(fCell, .Cells(FirstRow, .Columns.Count).End(xlToLeft)) _
            .Resize(LastRow - FirstRow + 1)

        Dim crg As Range, ErrNumber As Long, nmName As String

        For Each crg In rg.Columns

            nmName = CStr(crg.Cells(1).Value)

            On Error Resume Next
                .Names.Add nmName, "'" & wsName & "'!" & crg.Address
                ErrNumber = Err.Number
            On Error GoTo 0

            If ErrNumber <> 0 Then
                MsgBox "Could not add name """ & nmName & """.", vbCritical
                ErrNumber = 0
            End If

        Next crg

    End With
        
    MsgBox "Names added.", vbInformation

End Sub

• If you want the ranges of only the data (no headers), use the following:

Sub AddNamesData()
    
    Const FirstCol As String = "A"
    Const FirstRow As Long = 2
    Const LastRow As Long = 70
    
    With ActiveSheet
        
        Dim wsName As String: wsName = .Name
        
        Dim fCell As Range: Set fCell = .Cells(FirstRow, FirstCol)
        Dim rg As Range
        Set rg = .Range(fCell, .Cells(FirstRow, .Columns.Count).End(xlToLeft)) _
            .Resize(LastRow - FirstRow + 1)
        
        Dim hrg As Range: Set hrg = rg.Rows(1)
        Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
        
        Dim hCell As Range, c As Long, ErrNumber As Long, nmName As String
        
        For Each hCell In hrg.Cells
            
            c = c + 1
            nmName = CStr(hCell.Value)
            
            On Error Resume Next
                .Names.Add nmName, "'" & wsName & "'!" & drg.Columns(c).Address
                ErrNumber = Err.Number
            On Error GoTo 0
            
            If ErrNumber <> 0 Then
                MsgBox "Could not add name """ & nmName & """.", vbCritical
                ErrNumber = 0
            End If
        
        Next hCell
    
    End With
        
    MsgBox "Names added.", vbInformation

End Sub