Automatically assign Defined Names Based on Another Cell.

[ByeBye]

John	1
John	2
Mark	1
Mark	2
Bill	1
Bill	2

<tbody>
</tbody>

I'm looking to be able to assign all the John's to a John defined name automatically. I know how to automatically "create from selection" and use the left row but I want all the John's to have the same defined name and all the Marks to have The Mark defined name.

 

[Domenic]

The following macro assumes that the sheet containing the data is the active sheet, and that Columns A and B contain the data. Also, in an effort to ensure that the defined names are named according to the naming convention, the text "rng" is added to the beginning of the name, and any and all spaces are replaced with an underscore.

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] CreateDefinedNames()

    [COLOR=darkblue]Dim[/COLOR] dicNames [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] vKey [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] rData [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] sName [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] dicNames = CreateObject("Scripting.Dictionary")
    dicNames.CompareMode = 1
    
    [COLOR=darkblue]Set[/COLOR] rData = Range("A1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    
    [COLOR=darkblue]For[/COLOR] i = 1 [COLOR=darkblue]To[/COLOR] rData.Rows.Count
        sName = rData.Cells(i, 1).Value
        [COLOR=darkblue]If[/COLOR] Len(sName) > 0 [COLOR=darkblue]Then[/COLOR]
            [COLOR=darkblue]If[/COLOR] IsEmpty(dicNames(sName)) [COLOR=darkblue]Then[/COLOR]
                [COLOR=darkblue]Set[/COLOR] dicNames(sName) = rData.Rows(i)
            [COLOR=darkblue]Else[/COLOR]
                [COLOR=darkblue]Set[/COLOR] dicNames(sName) = Union(dicNames(sName), rData.Rows(i))
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] i
    
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] vKey [COLOR=darkblue]In[/COLOR] dicNames.keys
        ActiveWorkbook.Names.Add Name:="rng" & Replace(vKey, " ", "_"), RefersTo:="=" & dicNames(vKey).Address(, , , [COLOR=darkblue]True[/COLOR])
    [COLOR=darkblue]Next[/COLOR] vKey
    
    MsgBox "Completed . . .", vbInformation
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Hope this helps!

 

[ByeBye]

Thanks alot! That worked!

 

[Domenic]

You're very welcome!

Cheers!

 

[ByeBye]

In reviewing this, I seem to get the Column A and Column B in the drop down. I've dug through the code but can't seem to find where this portion is nor am I smart enough to tell the code not to do that since I only want column B. Any help would be appreciated.

 

[Domenic]

Try making the following changes in red...

Option Explicit

Sub CreateDefinedNames()

    Dim dicNames As Object
    Dim vKey As Variant
    Dim rData As Range
    Dim sName As String
    Dim i As Long
    
    Set dicNames = CreateObject("Scripting.Dictionary")
    dicNames.CompareMode = 1
    
    Set rData = Range("A1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    
    For i = 1 To rData.Rows.Count
        sName = rData.Cells(i, 1).Value
        If Len(sName) > 0 Then
            If IsEmpty(dicNames(sName)) Then
                Set dicNames(sName) = rData.[COLOR=#ff0000]Cells(i, 2)[/COLOR]
            Else
                Set dicNames(sName) = Union(dicNames(sName), rData.[COLOR=#ff0000]Cells(i, 2)[/COLOR])
            End If
        End If
    Next i
    
    For Each vKey In dicNames.keys
        ActiveWorkbook.Names.Add Name:="rng" & Replace(vKey, " ", "_"), RefersTo:="=" & dicNames(vKey).Address(, , , True)
    Next vKey
    
    MsgBox "Completed . . .", vbInformation
    
End Sub

 

[ByeBye]

Splendid, you code guys are an absolute lifesaver. I'm Forever indebted to you.