Solved: Filter list and place results below

[sassora]

I am trying to put a list of unique items at the end of my list in column A

For example
If the contents of column A is
a
a
a
b
c
c

then I want a macro to leave me with
a
a
a
b
c
c
a
b
c

Can you show me a way of doing this?

[stanleydgrom]

sassora,

Insert a column at column A.

Insert a row at cell A1.

Put a title in cell B1.

Highlight cell B1, down to the end of your list.

Click on Data, Filter, Advanced Filter...

Click in the box to the right of "Criteria range:"

Click in cell B1, then click in the box to the right of where the sheetname and cell B1 have been entered.

Click on the radio button for "Copy to another location".

Click in the box to the far right of "Copy to".

Highligh cell A1 down to the bottom of your data in column B.

Click in the box to the right of "Sheet1!$A$1:$A$7".

Click (put a checkmark) in the box for "Unique records only",

and click on "OK" button.

Copy the cells in Range("A2:A4"), to the bottom of the list in column B.

Delete column A.

Delete row 1.


Have a great day,
Stan

[stanleydgrom]

sassora,

Here you go.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Press and hold down the 'ALT' key, and press the 'F11' key.

Insert a Module in your VBAProject, Microsoft Excel Objects

Copy the below code, and paste it into the Module1.

 
Option Explicit
Sub Test()
    Dim lngColALastRow As Long
    Dim lngColBLastRow As Long
    With Range("A1")
        .EntireRow.Insert
        .EntireColumn.Insert
    End With
    Range("B1") = "Title"
    lngColBLastRow = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B1:B" & lngColBLastRow)
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1:A" & lngColBLastRow), Unique:=True
    End With
    lngColALastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A2:A" & lngColALastRow).Copy Range("B" & lngColBLastRow + 1)
    Application.CutCopyMode = False
    Columns("A:A").Delete
    Rows("1:1").Delete
    Range("B1").Select
End Sub

Then run the "Test" macro.


Have a great day,
Stan

[sassora]

Thanks, that's a great little macro.

[Charlize]

Data starts at A1. If not, change to your needs.
[vba]Sub Unique_To_End_Of_List()
'Collection only contains unique values
Dim mylist As New Collection
'use cell as range and as long ie. variant
Dim cell
'When adding duplicate items to a collection
'you receive an error. So continue and don't
'add a duplicate item
On Error Resume Next
'Change A1:A to A2:A if data starts at A2
For Each cell In Range("A1:A" & Range("A" & _
Rows.Count).End(xlUp).Row)
mylist.Add Item:=cell.Value, key:=CStr(cell.Value)
Next cell
'reset the error trapping to halt on errors
On Error GoTo 0
'loop through the collection and place them back
'where you want
For cell = 1 To mylist.Count
Range("A" & Range("A" & Rows.Count).End(xlUp). _
Offset(1, 0).Row).Value = mylist(cell)
Next cell
End Sub[/vba]Charlize