Find all Pears and then name the range as Pears

G

Guest

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.
 
B

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)
 
G

Guest

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
 
G

Guest

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...
 
Z

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
 
G

Guest

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

Martin


Bob Phillips said:
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)
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top