Filtering on multiple columns

W

wammer

I have similar data in multiple columns and I want to filter on all
columsn togather to get unique values. Is there a good way to do so.
 
D

Dave Peterson

I'd create a new worksheet and copy all the data into one column. Then I'd use
data|filter|Advanced filter to extract just the unique records.

Debra Dalgleish explains the data|filter|advanced filter stuff at:
http://www.contextures.com/xladvfilter01.html#FilterUR

If your combined list is too large, you can use advanced filter on each column
and then merge those unique records together and do one more advanced filter.
 
W

wammer

The problem is that I have 247 columns and 5000 rows so it will take a
long time to do it individually. Is there a Macro I could write?
 
D

Dave Peterson

All 247 columns in one worksheet? And 5000 rows per column???

How many unique entries do you expect (possible 247*5000=1,235,000) way too many
for this techique to work.

This seemed to work ok for me.

Option Explicit
Sub testme()
Dim curWks As Worksheet
Dim newWks As Worksheet
Dim FirstCol As Long
Dim LastCol As Long
Dim FirstRow As Long
Dim iCol As Long
Dim DestCell As Range

Set curWks = Worksheets("sheet1")
Set newWks = Worksheets.Add

With curWks
FirstRow = 2 'headers in row 1
FirstCol = 1
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

newWks.Range("a1").Value = "Header"
Set DestCell = newWks.Range("a2")

For iCol = FirstCol To LastCol
.Range(.Cells(FirstRow, iCol), _
.Cells(.Rows.Count, iCol).End(xlUp)).Copy _
Destination:=DestCell
With newWks
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp)
If DestCell.Row > 40000 Then
Call doAdvancedFilter(.Range("a:a"))
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp)
End If
End With
Next iCol
End With

'and once more for good measure!
With newWks
Call doAdvancedFilter(.Range("a:a"))
Set DestCell = .UsedRange 'try to reset last used cell
End With

End Sub

Sub doAdvancedFilter(rng As Range)
rng.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=rng(1).Offset(0, 1), Unique:=True
rng.Delete
End Sub
 
Top