Macro for defining a range

**studentUH** · 08-21-2008, 04:09 PM

Hello this is my first post and i am in need of help. I need to have a macro that will automaticaly create ranges. (define a range) .

I would like a macro that would look in column D and look for the section that has "2" and name that section "oldt", if "7" name new "newnt", if "8" name "newt". The last column will always be "O"

I have attached what the file i am working looks like.

Please help if you can.

Thanks

**studentUH** · 08-21-2008, 04:22 PM

can anyone solve this?

**royUK** · 08-21-2008, 04:45 PM

have some patience. Is this what you mean?

Option Explicit

Sub addName()
    Dim rng    As Range
    Dim cl     As Range
    Dim MyRange As Range
    Dim MyRange2 As Range
    Dim MyRange3 As Range

    Set rng = Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp))

    For Each cl In rng
        Select Case cl.Value
            Case 7
                If MyRange Is Nothing Then
                    Set MyRange = cl
                Else: Set MyRange = Union(MyRange, cl)
                End If
            Case 2
                If MyRange2 Is Nothing Then
                    Set MyRange2 = cl
                Else: Set MyRange2 = Union(MyRange2, cl)
                End If
            Case 8
                If MyRange3 Is Nothing Then
                    Set MyRange3 = cl
                Else: Set MyRange3 = Union(MyRange3, cl)
                End If
        End Select
    Next cl
    With ThisWorkbook
        .Names.Add Name:="newnt", _
                   RefersTo:=MyRange, Visible:=True
        .Names.Add Name:="oldt", _
                   RefersTo:=MyRange2, Visible:=True
        .Names.Add Name:="newt", _
                   RefersTo:=MyRange3, Visible:=True
        End With
    End Sub

**royUK** · 08-21-2008, 04:50 PM

You have already been asked to read the rules, if you read them all you will see you are asked not to use unnecessary words in the title like Easy. In any case if the code is easy why ask?

**studentUH** · 08-21-2008, 05:54 PM

THANKS!! this is very close to what i need, instead of just naming the cells in column D i need it to also capture all cells to the left and right.

so for example in the file that i uploaded "newnt" would be from A10 O15

**Leith Ross** · 08-21-2008, 06:57 PM

Hello studentUH,

This is macro will create the named ranges covering columns "A to "O". Call the macro "Run" to create your ranges.

Private Sub CreateNamedRange(Search_Value As Variant, Range_Name As String)

  Dim Col As Variant
  Dim FirstAddx As String
  Dim LastRow As Long
  Dim NewRng As Range
  Dim Result As Range
  Dim StartRow As Long
  
    Col = "D"
    StartRow = 2
    
      LastRow = Cells(Rows.Count, "D").End(xlUp).Row
      LastRow = IIf(LastRow < StartRow, StartRow, LastRow)
      
      Set Rng = Range(Cells(StartRow, Col), Cells(LastRow, Col))
      
        Set Result = Rng.Find(What:=Search_Value, _
                               After:=Rng.Cells(1, 1), _
                               LookIn:=xlValues, _
                               LookAt:=xlWhole, _
                               SearchOrder:=xlRows, _
                               SearchDirection:=xlNext, _
                               MatchCase:=False)
                               
        If Not Result Is Nothing Then
          FirstAddx = Result.Address
          Set NewRng = Result
            Do
              Set NewRng = Union(NewRng, Result)
              Set Result = Rng.FindNext(Result)
            Loop While Result.Address <> FirstAddx And Not Result Is Nothing
        End If
     
     If Not NewRng Is Nothing Then
       StartRow = NewRng.Row
       LastRow = NewRng.Rows.Count + StartRow - 1
         Set NewRng = Range(Cells(StartRow, "A"), Cells(LastRow, "O"))
       Range_Name = Replace(Range_Name, " ", "_")
       ThisWorkbook.Names.Add _
         Name:=Range_Name, _
         RefersTo:="=" & NewRng.Parent.Name & "!" & NewRng.Address
     End If
     
End Sub

Sub Run()

  CreateNamedRange 2, "oldt"
  CreateNamedRange 7, "newnt"
  CreateNamedRange 8, "newt"

End

Sincerely,
Leith Ross

**royUK** · 08-22-2008, 01:51 AM

Try this amended code

Option Explicit



Sub addName()
    Dim rng    As Range
    Dim cl     As Range
    Dim MyRange As Range
    Dim MyRange2 As Range
    Dim MyRange3 As Range

    Set rng = Range(Cells(2, 4), Cells(Rows.Count, 4).End(xlUp))

    For Each cl In rng
        Select Case cl.Value
            Case 7
                If MyRange Is Nothing Then
                    Set MyRange = Range(Cells(cl.Row, 1), Cells(cl.Row, 15))
                Else: Set MyRange = Union(MyRange, Range(Cells(cl.Row, 1), Cells(cl.Row, 15)))
                End If
            Case 2
                If MyRange2 Is Nothing Then
                    Set MyRange2 = Range(Cells(cl.Row, 1), Cells(cl.Row, 15))
                Else: Set MyRange2 = Union(MyRange2, Range(Cells(cl.Row, 1), Cells(cl.Row, 15)))
                End If
            Case 8
                If MyRange3 Is Nothing Then
                    Set MyRange3 = Range(Cells(cl.Row, 1), Cells(cl.Row, 15))
                Else: Set MyRange3 = Union(MyRange3, Range(Cells(cl.Row, 1), Cells(cl.Row, 15)))
                End If
        End Select
    Next cl
    With ThisWorkbook
        .Names.Add Name:="newnt", _
                   RefersTo:=MyRange, Visible:=True
        .Names.Add Name:="oldt", _
                   RefersTo:=MyRange2, Visible:=True
        .Names.Add Name:="newt", _
                   RefersTo:=MyRange3, Visible:=True
    End With
End Sub