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

--
Regards,
Zack Barresse, aka firefytr, (GT = TFS FF Zack)
To email, remove the NO SPAM. Please keep correspondence to the board, as
to benefit others.



"Martin" wrote in message
...
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.

--
Regards,

Martin