VBA modification on earlier solution by Rgonzo1971

I had this question after viewing VBA modification help needed from earlier solution by Rgonzo1971 Dynamic Rng.

Rgonzo1971 was kind to help me with this code below.

it creates named range based on the selected columns.  but this only works if the selected columns are adjacent to each other.

if i select couple of column and there are some columns in between that are not selected then some other column then it will not work.

please see example.  i selected column Month and AMOUNT,  only of them only gets created while both of them are selected.
2017-12-05-20_51_43-Name-Manager.png



 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
    
    wbk.Names.Add Name:="rData", RefersTo:="='" & sht.Name & "'!$1:$1048576"
    wbk.Names.Add Name:="Lrow", RefersTo:="=LOOKUP(9.99999999999999E+307,1/(1-ISBLANK('" & sht.Name & "'!$A:$A)),ROW('" & sht.Name & "'!$A:$A))"
    
    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(INDIRECT(ADDRESS(2,MATCH(""" & Cells(1, c) & """,INDEX(rData,1,0),0))),,,Lrow-1)"

       End If
    Next
End Sub

Open in new window

EE.xlsb
LVL 6
FloraAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
Sub Create_RangeNames1()
     'Creates dynamic named ranges based on header row information only Selection
    Dim wbk As Workbook
    Dim sht As Worksheet
    Dim rng As Range, rng2 As Range
    Dim cl As Range 'Object
    Dim c As Long
    Dim strAddr As Variant
    Dim strShName, strHdrName, strCol As String
    Dim rngCol As Range
    Dim r As Range
    Set wbk = ActiveWorkbook
    Set sht = ActiveSheet
    'Set rng = Selection
    For Each rngCol In Selection.Columns
        Set r = Intersect(Selection, rngCol)
        If r.Address = rngCol.EntireColumn.Address Then
            If rng Is Nothing Then
                Set rng = r
            Else
                Set rng = Union(rng, r)
            End If
        End If
    Next

    
    wbk.Names.Add Name:="rData", RefersTo:="='" & sht.Name & "'!$1:$1048576"
    wbk.Names.Add Name:="Lrow", RefersTo:="=LOOKUP(9.99999999999999E+307,1/(1-ISBLANK('" & sht.Name & "'!$A:$A)),ROW('" & sht.Name & "'!$A:$A))"

    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(INDIRECT(ADDRESS(2,MATCH(""" & Cells(1, c) & """,INDEX(rData,1,0),0))),,,Lrow-1)"

       End If
    Next
End Sub

Open in new window


BTW when you do things like Dim strShName, strHdrName, strCol As String, only strCol is a String. The other two are Variants.
FloraAuthor Commented:
thanks Martin.

but it gives the same result as Rgonzo1971's code.

i have uploaded a dummy example.  try to select both yellow columns and run the macro.  you will see that named range AMount is not created
Martin LissOlder than dirtCommented:
 Sub Create_RangeNames1()
     'Creates dynamic named ranges based on header row information only Selection
    Dim wbk As Workbook
    Dim sht As Worksheet
    Dim rng As Range, rng2 As Range
    Dim cl As Range 'Object
    Dim c As Long
    Dim strAddr As Variant
    Dim strShName, strHdrName, strCol As String
    Dim rngCol As Range
    Dim r As Range
    Dim strFormula As String
    Const QUOTE = """"

    Set wbk = ActiveWorkbook
    Set sht = ActiveSheet
    
    For Each rngCol In Selection.Columns
        Set r = Intersect(Selection, rngCol)
        If r.Address = rngCol.EntireColumn.Address Then
            If rng Is Nothing Then
                Set rng = r
            Else
                Set rng = Union(rng, r)
            End If
        End If
    Next

    
    wbk.Names.Add Name:="rData", RefersTo:="='" & sht.Name & "'!$1:$1048576"
    wbk.Names.Add Name:="Lrow", RefersTo:="=LOOKUP(9.99999999999999E+307,1/(1-ISBLANK('" & sht.Name & "'!$A:$A)),ROW('" & sht.Name & "'!$A:$A))"

    If Cells(1, rng.Areas(1).Column).Value <> "" Then
        strShName = Replace(sht.Name, " ", "_", 1)
        strHdrName = Replace(Cells(1, rng.Areas(1).Column).Value, " ", "_", 1)
    End If
    For c = 1 To rng.Areas.Count
        If strFormula = "" Then
            strFormula = "=OFFSET(" & strShName & "!" & rng.Areas(c).Address & ",0,0,COUNTA(" & strShName & "!" & rng.Areas(c).Address & ")-1,1)"
        Else
            strFormula = strFormula & ",OFFSET(" & strShName & "!" & rng.Areas(c).Address & ",0,0,COUNTA(" & strShName & "!" & rng.Areas(c).Address & ")-1,1)"
        End If
    Next
    wbk.Names.Add Name:=strShName & strHdrName, RefersTo:=strFormula
End Sub

Open in new window

CompTIA Security+

Learn the essential functions of CompTIA Security+, which establishes the core knowledge required of any cybersecurity role and leads professionals into intermediate-level cybersecurity jobs.

Martin LissOlder than dirtCommented:
You should add error checking similar to this after line 28.
    If rng Is Nothing Then
        MsgBox "No columns selected"
        Exit Sub
    End If

Open in new window

FloraAuthor Commented:
thank you Martin.

it works. but it messed up my namedranges.  my original one was creating from row 2 to the last row.  your macro takes the first row which is the header as well.

can u plz fix?
Martin LissOlder than dirtCommented:
 Sub Create_RangeNames1()
     'Creates dynamic named ranges based on header row information only Selection
    Dim wbk As Workbook
    Dim sht As Worksheet
    Dim rng As Range, rng2 As Range
    Dim cl As Range 'Object
    Dim c As Long
    Dim strAddr As Variant
    Dim strShName, strHdrName, strCol As String
    Dim rngCol As Range
    Dim r As Range
    Dim strFormula As String
    Dim intStart As Integer
    Dim intEnd As Integer
    Const QUOTE = """"

    Set wbk = ActiveWorkbook
    Set sht = ActiveSheet
 
    For Each rngCol In Selection.Columns
        Set r = Intersect(Selection, rngCol)
        If r.Address = rngCol.EntireColumn.Address Then
            If rng Is Nothing Then
                Set rng = r
            Else
                Set rng = Union(rng, r)
            End If
        End If
    Next

    If rng Is Nothing Then
        MsgBox "No columns selected"
        Exit Sub
    End If
    
    wbk.Names.Add Name:="rData", RefersTo:="='" & sht.Name & "'!$1:$1048576"
    wbk.Names.Add Name:="Lrow", RefersTo:="=LOOKUP(9.99999999999999E+307,1/(1-ISBLANK('" & sht.Name & "'!$A:$A)),ROW('" & sht.Name & "'!$A:$A))"

    If Cells(1, rng.Areas(1).Column).Value <> "" Then
        strShName = Replace(sht.Name, " ", "_", 1)
        strHdrName = Replace(Cells(1, rng.Areas(1).Column).Value, " ", "_", 1)
    End If
    For c = 1 To rng.Areas.Count
        If strFormula = "" Then
            strFormula = "=OFFSET(" & strShName & "!" & rng.Areas(c).Address & ",0,0,COUNTA(" & strShName & "!" & rng.Areas(c).Address & ")-1,1)"
            ' I couldn't figure out how to adjust the Areas to start at row 2, so this is a workaround.
            intStart = InStr(1, strFormula, "$")
            intEnd = InStr(intStart, strFormula, ",")
            strFormula = Left(strFormula, intStart + 1) & "2" & Mid(strFormula, intEnd)
        Else
            strFormula = strFormula & ",OFFSET(" & strShName & "!" & rng.Areas(c).Address & ",0,0,COUNTA(" & strShName & "!" & rng.Areas(c).Address & ")-1,1)"
            intStart = InStr(intStart, strFormula, "OFFSET")
            intStart = InStr(intStart, strFormula, "$")
            intEnd = InStr(intStart, strFormula, ",")
            strFormula = Left(strFormula, intStart + 1) & "2" & Mid(strFormula, intEnd)
        End If
    Next
    wbk.Names.Add Name:=strShName & strHdrName, RefersTo:=strFormula
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FloraAuthor Commented:
thanks Martin.

i will post a follow up question.
FloraAuthor Commented:
your latest code did not work.
Martin LissOlder than dirtCommented:
Please explain what you mean when you say it didn't work. Here's what I get which I assume is what you want.
Cursor_and_Name_Manager.jpg
FloraAuthor Commented:
dear Martin.

i have recorded and attached video that shows what your code does.

first of all. it creates one named range fro two columns which is not correct. i want each column to have separate name range with the header being the name of the named range.  

in addition it uses counta which you can see that named ranges leaves out alot of data.

your answer a42393338  was much closed, but then the last one was not correct at all.

thanks for your help anyway
Recorded.mp4
Martin LissOlder than dirtCommented:
I want each column to have separate name range with the header being the name of the named range.  
Oh!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.