VBA Named Ranges inc Sheet title

[bongpsumera]

Hi,

I'm not sure if this has been covered but I'm looking everywhere for a short piece of VBA code to create named ranges from the columns off a sheet and include the sheet name as a prefix for the named range.

I've managed to find the following:

   Dim wbk As Workbook
    Dim Sht As Worksheet
    Dim rng6, rng7 As Range
    Dim cl As Object
    Dim c As Long
    Dim strAddr As Variant
    Dim strShName, strHdrName, strCol As String
    
    Set wbk = ActiveWorkbook
   Set Sht = Sheets("Raw")
        c = Sht.Cells.SpecialCells(xlLastCell).Column
        Set rng6 = Sht.Range("A1", Sht.Range("A1").Offset(0, c))
        For Each cl In rng6
            If cl.Value <> "" Then
                strShName = Replace(Sht.Name, " ", "_", 1)
                strHdrName = Replace(cl.Value, " ", "_", 1)
                strAddr = Split(cl.Address, "$")
                strCol = "$" & strAddr(1) & ":$" & strAddr(1)
                Set rng7 = Sht.Range(cl, cl.End(xlDown))
                ActiveWorkbook.Names.Add Name:=strShName & strHdrName, _
                    RefersTo:="=OFFSET('" & Sht.Name & "'!" & cl.Address & ",0,0,COUNTA('" & _
                    Sht.Name & "'!" & strCol & "),1)"
            End If
        Next cl

But if there are blank cells in a column it seems to shorten the range in the column (I suspect this has to do with the COUNTA offset).

The last row for each of the ranges should be determined from the last row in column A.

i.e.

Dim lastrow As Long
lastrow = Range("A655636").End(xlUp).Row

Any assistance would be greatly appreciated.

[Bob Phillips]

Const FORMULA_REFERSTO As String = _
    "=OFFSET('<sheet>'!<cell>,0,0,<height>,1)"
Dim wbk As Workbook
Dim Sht As Worksheet
Dim rng6, rng7 As Range
Dim cl As Object
Dim c As Long, lastrow As Long
Dim strAddr As Variant
Dim strShName, strHdrName, strCol As String
 
    Set wbk = ActiveWorkbook
    Set Sht = wbk.Worksheets("Raw")
    c = Sht.Cells.SpecialCells(xlLastCell).Column
    Set rng6 = Sht.Range("A1", Sht.Range("A1").Offset(0, c))
    For Each cl In rng6
    
        If cl.Value <> "" Then
        
            strShName = Replace(Sht.Name, " ", "_", 1)
            strHdrName = Replace(cl.Value, " ", "_", 1)
            lastrow = Sht.Cells(Sht.Rows.Count, cl.Column).End(xlUp).Row
            Set rng7 = Sht.Range(cl, cl.End(xlDown))
            Sht.Names.Add Name:=strShName & strHdrName, _
                          RefersTo:=Replace(Replace(Replace(FORMULA_REFERSTO, "<sheet>", Sht.Name), "<cell>", cl.Address), "<height>", lastrow)
        End If
    Next cl
End Sub