Find all Pears and then name the range as Pears

[Martin]

Dear all,

I have a spreadsheet that looks like this:

Column A
Apple
Apple
Apple
Pear
Pear
Pear
Pear
Orange
Orange

The number of rows with Pears change from time to time and I want a macro to
find all the cell with Pear and then name the range as Pears.

Does anyone know how to do this? Any help much appreciated.

 

[Bob Phillips]

Simple way.

For i = 1 To Cells(Rows.Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "Pears" then
If rng Is Nothing Then
Set rng = Cells(i,"A")
Else
Set rng = Union(rng,Cells(i,"A")
End If
End If
Next i

If Not rng Is Nothing Then
rng.Name = "Pears"
End If

--

HTH

Bob Phillips

(remove nothere from the email address if mailing direct)

 

[Jim Thomlinson]

Try this

Sub test()
Call AddName("Pear")
End Sub

Public Sub AddName(ByVal Fruit As String)
Dim wks As Worksheet
Dim rngToSearch As Range
Dim rngFound As Range
Dim rngFoundAll As Range
Dim strFirstAddress As String

Set wks = ActiveSheet
Set rngToSearch = wks.Columns("A")
Set rngFound = rngToSearch.Find(What:=Fruit, _
LookIn:=xlConstants, _
LookAt:=xlPart)
If Not rngFound Is Nothing Then
Set rngFoundAll = rngFound
strFirstAddress = rngFound.Address
Do
Set rngFoundAll = Union(rngFound, rngFoundAll)
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = strFirstAddress
ThisWorkbook.Names.Add Fruit, rngFoundAll.Address
End If
End Sub

 

[Jim Thomlinson]

If the list of items is short Use Bob's code. It is simple and easy to
understand. If your list is long then use the code that I posted as it is
quite a bit more efficient...

 

[Zack Barresse]

I had a little different way. You can run this multiple times as well.

Option Explicit
Sub NameUniqueValueRanges()
'declare variables
Dim wb As Workbook
Dim wsFilter As Worksheet, wsTemp As Worksheet
Dim rngLook As Range, rngLoop As Range
Dim rngFilter As Range, c As Range
Dim strName As String

Application.DisplayAlerts = False
Application.ScreenUpdating = False

'set variables
Set wb = ActiveWorkbook
Set wsFilter = wb.Sheets(1) 'assuming the first/left-most sheet in
activeworkbook
Set wsTemp = wb.Sheets.Add(after:=Sheets(1))
Set rngLook = wsFilter.Range("A1", wsFilter.Cells(Rows.Count,
"A").End(xlUp))
Set rngFilter = wsFilter.Range("A2", wsFilter.Cells(Rows.Count,
"A").End(xlUp))

'turn off autofilter
AutoFilterOff wsFilter

With rngLook

'create a unique list
.AdvancedFilter xlFilterCopy, copytorange:=wsTemp.Range("A1"),
unique:=True

Set rngLoop = wsTemp.Range("A2", wsTemp.Cells(Rows.Count,
"A").End(xlUp))

On Error Resume Next
For Each c In rngLoop

'filter criteria
.AutoFilter field:=1, Criteria1:=c.Value

'set named range
wb.Names(c.Value).Delete
strName = rngFilter.SpecialCells(xlCellTypeVisible).Address
wb.Names.Add c.Value, "=" & wsFilter.Name & "!" & strName

Next c
On Error GoTo 0

End With

'clean up
wsTemp.Delete
wsFilter.Activate
AutoFilterOff wsFilter
Application.DisplayAlerts = False
Application.ScreenUpdating = False

End Sub
Sub AutoFilterOff(ws As Worksheet)
If ws.AutoFilterMode = True Then ws.Cells.AutoFilter
End Sub


HTH

 

[Martin]

Thank you very much. It is working like a dream
--
Regards,

Martin

Simple way.

For i = 1 To Cells(Rows.Count,"A").End(xlUp).Row
If Cells(i,"A").Value = "Pears" then
If rng Is Nothing Then
Set rng = Cells(i,"A")
Else
Set rng = Union(rng,Cells(i,"A")
End If
End If
Next i

If Not rng Is Nothing Then
rng.Name = "Pears"
End If

--

HTH

Bob Phillips

(remove nothere from the email address if mailing direct)