Excel Formula or VBA code help needed

[bruce taylor]

This may be enough to get you started

Sub unique_values()
'Creates a sorted list of unique values starting at Target
'Rev A 27/5/2003

'PRELIMINARIES
Dim Examine As String, Target As String, ThisPrompt As
String, title As String
Dim UserRng_A As Range, UserRng_B As Range
Dim valu As Variant

'STEP 1 DETERMINE WHERE THE RAW DATA IS
ThisPrompt = "Where is the top of the VALUES to test ? eg
A3 or B5"
title = "UNIQUE VALUES (Rev A)"
On Error Resume Next ' in case a range does not get
selected
'The use of the "Set" statement assigns the output to the
selected ActiveCell
Set UserRng_A = Application.InputBox(prompt:=ThisPrompt,
title:=title, _
Default:=ActiveCell.Address, Type:=8) '"Type 8" means a
Range result.
If UserRng_A Is Nothing Then 'input was box cancelled
MsgBox "Cancelled"
Exit Sub ' Rev A
End If

'STEP 2 DETERMINE WHERE TO PUT THE LIST
ThisPrompt = "Where is the Data to be put ?" _
& Chr(13) & Chr(13) & "You will need blank cells under the
it."
Set UserRng_B = Application.InputBox(prompt:=ThisPrompt,
title:="Select a cell", _
Default:=ActiveCell.Address, Type:=8)
If UserRng_B Is Nothing Then
MsgBox "Cancelled"
Exit Sub ' Rev A
End If
Target = UserRng_B.Address() 'the address of the selected
cell

'STEP 3 GATHER BASIC DATA
Application.ScreenUpdating = False
UserRng_A(0, 1).Select 'select the cell above
Examine = Selection.Address() 'the address of the cell
above
valu = Selection.Formula 'store the contents of the cell
one row above the first data
UserRng_A(0, 1).Formula = "temporary string" 'THE ADVANCED
FILTER DEMANDS A STRING IN THIS CELL


'STEP 4 CREATE THE UNIQUE ENTRIES
Range(Target).Clear 'needed to stop filtering falling over
Range(Examine).Activate 'filter then insert unique values
starting at Target
Range(Examine, ActiveCell.End(xlDown)).AdvancedFilter
Action:=xlFilterCopy, _
CopyToRange:=Range(Target), Unique:=True
'now sort the values
Range(Target).Select 'musn't remove this line
Range(Target, ActiveCell.End(xlDown)).Select
Selection.Sort Key1:=Range(Target), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1

'STEP 5 TIDY UP
UserRng_B.Formula = ""
Range(Examine).Formula = valu 'restore the original entry
to this cell
Application.ScreenUpdating = True

End Sub

 

[Michael168]

Hi ! bruce taylor

Thank you for your kind and fast reply.

I will try and let you know the outcome if it is what I want.
Can I have your email contact.
Thank you.

Michael168