为每列添加名称

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

• 如果只需要数据的范围（没有标题），请使用以下命令：

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