How can I rename each column of a table? - excel

Question

So I have a table with X columns, and I want to rename each with its own name.
I want to rename the first column using the string on A1, the second with the string on B1, 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?
Note: No, the table isn't an object, so ActiveWorkbook.Sheets("Sheet").ListObjects("Table").ListColumns("Column name").Name = "New column name" doesn't work.
Note 2: I'm using Excel 2013

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