asked on
Sub Create_RangeNames1()
'Creates dynamic named ranges based on header row information only Selection
Dim wbk As Workbook
Dim sht As Worksheet
Dim rng, rng2 As Range
Dim cl As Range 'Object
Dim c As Long
Dim strAddr As Variant
Dim strShName, strHdrName, strCol As String
Set wbk = ActiveWorkbook
Set sht = ActiveSheet
Set rng = Selection
For c = rng.Column To rng.Column + rng.Columns.Count - 1
If Cells(1, c).Value <> "" Then
strShName = Replace(sht.Name, " ", "_", 1)
strHdrName = Replace(Cells(1, c).Value, " ", "_", 1)
strCol = Cells(2, c).EntireColumn.Address
Set rng2 = sht.Range(Cells(, c), Cells(1, c).End(xlDown))
wbk.Names.Add Name:=strShName & strHdrName, _
RefersTo:="=OFFSET('" & sht.Name & "'!" & Cells(2, c).Address & ",0,0,SUMPRODUCT(MAX(('" & sht.Name & "'!" & strCol & "<>"""")*ROW('" & sht.Name & "'!" & strCol & ")))-1,1)"
End If
Next
End Sub