Macro to auto Name a Range based on criteria

[Guest]

Hello,
This is somewhat complicated, so I will try to explain best I can. I have a
data worksheet is a wb that is update weekly and new data is dumped on top of
it. In the data, there are 250 rows with 6 columns. Column B has various
departments and Column C has the positions that go with the department. For
certain validation criteria, I need to name the range of only the positions
(col C) that are in each department. So the data looks like this:
Front Desk Agent
Front Desk Supervisor
Front Desk Asst Mgr
Front Desk Mgr
Housekeeping Housekeeper
Housekeeping Houseman
etc...etc...etc..

So, I would like to be able to run a macro and it would redefine the ranges
for Front Desk and only use the positions. Then go on to housekeeping and so
on.

Any assistance would be gratefull.

 

[Guest]

Give this a go:

Sub NameThem()

Dim lRow As Long
Dim counter As Long
Dim Dept As String
Dim newDept As String
Dim sRow As Integer
Dim eRow As Integer
Dim chk As Range
Dim colB As Range

lRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Set colB = Range(Cells(2, 2), Cells(lRow, 2))
Dept = Trim(Cells(2, 2).Value)
newDept = Replace(Dept, " ", "")
sRow = 2
eRow = 2
For Each chk In colB
If chk.Value <> Dept Then
ActiveWorkbook.Names.Add Name:=newDept, _
RefersToR1C1:="=Sheet2!R" & sRow & "C3:R" & eRow & "C3"
Dept = chk.Value
newDept = Replace(Dept, " ", "")
sRow = chk.Row
eRow = chk.Row
Else
eRow = chk.Row
End If
Next chk
End Sub

Hope this helps
Rowan

 

[Guest]

PERFECT!!! Thanks!
Mike

Give this a go:

Sub NameThem()

Dim lRow As Long
Dim counter As Long
Dim Dept As String
Dim newDept As String
Dim sRow As Integer
Dim eRow As Integer
Dim chk As Range
Dim colB As Range

lRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Set colB = Range(Cells(2, 2), Cells(lRow, 2))
Dept = Trim(Cells(2, 2).Value)
newDept = Replace(Dept, " ", "")
sRow = 2
eRow = 2
For Each chk In colB
If chk.Value <> Dept Then
ActiveWorkbook.Names.Add Name:=newDept, _
RefersToR1C1:="=Sheet2!R" & sRow & "C3:R" & eRow & "C3"
Dept = chk.Value
newDept = Replace(Dept, " ", "")
sRow = chk.Row
eRow = chk.Row
Else
eRow = chk.Row
End If
Next chk
End Sub

Hope this helps
Rowan