VBA modification help needed to revise the formula

Flora Edwards
Flora Edwards used Ask the Experts™
on
I have this best code.  also in the attached workbook.

if you select the column A and then run this macro. it will add a dynamic named range  =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),1)

i need help with modification of VBA code that instead of creating =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),1)  I need the VBA to Create this =OFFSET(Sheet1!$A$2,0,0,SUMPRODUCT(MAX((Sheet1!$A:$A<>"")*ROW(Sheet1!$A:$A)))-1,1)  

how can this code below be modified?


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 = 1 To rng.Columns.Count
        If Cells(1, c).Value <> "" Then
            strShName = Replace(sht.Name, " ", "_", 1)
            strHdrName = Replace(Cells(1, c).Value, " ", "_", 1)
            strAddr = Split(Cells(1, c).Address, "$")
            strCol = "$" & strAddr(1) & ":$" & strAddr(1)
            Set rng2 = sht.Range(Cells(, c), Cells(1, c).End(xlDown))
             wbk.Names.Add Name:=strShName & strHdrName, _
                RefersTo:="=OFFSET('" & sht.Name & "'!" & Cells(1, c).Address & ",0,0,COUNTA('" & _
                sht.Name & "'!" & strCol & "),1)"
       End If
    Next
End Sub

Open in new window

EE.xlsb
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
Rgonzo1971
Top Expert 2016

Commented:
Hi,

pls try 
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 = 1 To rng.Columns.Count
        If Cells(1, c).Value <> "" Then
            strShName = Replace(sht.Name, " ", "_", 1)
            strHdrName = Replace(Cells(1, c).Value, " ", "_", 1)
            strAddr = Split(Cells(1, c).Address, "$")
            strCol = "$" & strAddr(1) & ":$" & strAddr(1)
            Set rng2 = sht.Range(Cells(, c), Cells(1, c).End(xlDown))
             wbk.Names.Add Name:=strShName & strHdrName, _
                RefersTo:="=OFFSET('" & sht.Name & "'!" & Cells(1, c).Address & ",0,0,SUMPRODUCT(MAX(('" & sht.Name & "'!" & strCol & "<>"""")*ROW('" & sht.Name & "'!" & strCol & ")))-1,1)"
       End If
    Next
End Sub

Open in new window

EDIT corrected code

Regards
Flora EdwardsMedicine

Author

Commented:
Thanks Rgonzo.

your code creates the same thing which is =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),1)


i needed the code to create =OFFSET(Sheet1!$A$2,0,0,SUMPRODUCT(MAX((Sheet1!$A:$A<>"")*ROW(Sheet1!$A:$A)))-1,1)   instead
Top Expert 2016
Commented:
corrected code
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 = 1 To rng.Columns.Count
        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

Open in new window

Flora EdwardsMedicine

Author

Commented:
Thanks A Million!  very much appreciated Rgonzo1971

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial