PDA

View Full Version : VBA Named Ranges inc Sheet title



bongpsumera
06-25-2017, 11:02 PM
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
06-26-2017, 02:15 AM
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