Challenging: VBA to Combine (1) Naming Ranges with Another Range's Values; (2) Row & Column Loops; (Finding Last Row/Column)

[MikeUsername]

I have a lot of ranges I need to name. I want to use VBA to name every range in a column by referencing another column that contains the range names to be used. For instance, I want to name cell E3 (which has a value of 1) with the name in cell A3 (JillJan). Then, name cell E4 (which has a value of 2) with the name in cell A4 (TomJan). Then, continue the process: name E5 with A5, E6 with A6, then move over one column (when it gets to the last value in column E) and name F3 with B3, F4 with B4, F5 with B5, F6 with B6, then move over one column and name G3 with C3, G4 with C4, G5 with C5, and G6 with C6. Effectively, I need to combine four tasks:

(1) Adding names: ActiveWorkbook.Names.Add Name:=Range("A3").Value, RefersTo:=Range("E3") Or, instead of A3 & E3: R3C1 & R3C5
(2) Loop through Rows: From 3 to 4 to 5 to 6
(3) Loop through Columns: From E to F to G
(4) Find the last row -- so it moves to the next column and move from column E to F to G; and find the last column and last row (Cell G6) so it knows when to stop the loop.

	A	B	C	D	E	F	G
1	Range Names	Range Names	Range Names
2	For January	For February	For March	Salespeople	January	February	March
3	JillJan	JillFeb	JillMar	Jill	1	5	9
4	TomJan	TomFeb	TomMar	Tom	2	6	10
5	LarryJan	LarryFeb	LarryMar	Larry	3	7	11
6	HalJan	HalFeb	HalMar	Hal	4	8	12

<colgroup><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

I am not sure how to do this but it might look something like the below code.
Thank you for any thoughts you may have.

Sub LoopRows&Columns()
Dim MyRows As Long
Dim MyColumns As Long

'Set a Loop For Columns so that we have a loop within a loop that goes through the four rows and then loops through the three columns
'

'Set Loop for Rows
MyRows = 1
With ActiveSheet
Do While MyRows <= .Rows.Count
If .Cells(MyRows, 1) <> "" Then
'Code to Name Cells Here, i.e. ActiveWorkbook.Names.Add Name:=Range("A3toA4toA5toA6").Value, RefersTo:=Range("E3toE4toE5toE6")
Else
Exit Do
End If
MyRows = MyRows + 1
Loop
End With
End Sub

 

[Leith Ross]

Hello MikeUsername,

This macro is based on the table you posted. If your actual layout is different from this table then macro will need to be adjusted.

Option Explicit


Sub CreateNamedRanges()


    Dim Cell    As Range
    Dim col     As Long
    Dim Rng     As Range
    Dim rngName As String
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        Set Rng = Wks.Range("A1").CurrentRegion
        
            ' Find the header "Sales people" that divides the range. Exit if if is not found.
            Set Cell = Rng.Find("Sales*people", , xlValues, xlPart, xlByRows, xlNext, False, False, False)
            If Cell Is Nothing Then Exit Sub
            
            ' This is the dividing column number within Rng.
            col = Cell.Column - Rng.Column + 1
            
            ' Remove the 2 header rows from Rng and resize it.
            Set Rng = Intersect(Rng, Rng.Offset(2, 0)).Resize(ColumnSize:=col - 1)
            
            ' Loop through columns then rows.
            For Each Cell In Rng
                rngName = Cell.Value
                On Error Resume Next
                    ' Test if the named range exists.
                    rngName = ThisWorkbook.Names(rngName).Name
                    If Err <> 0 Then
                        ' Add the range name.
                        ThisWorkbook.Names.Add Name:=rngName, RefersTo:=Cell.Offset(0, col)
                    End If
                On Error GoTo 0
            Next Cell
                
End Sub