AdvancedFilter with Blank Rows - Any Help

[Bala]

Hi,
Can anyone help for the following scenario?

I have an excel sheet in the following format,
where the cell values C8,D5,C10,D10 etc. are blank values(empty cell
values)

Sl No Name Age Place Mark
1 A 21 Place1 45
2 A 22 Place2 45
3 A 21 Place3 45
4 A 22 45
5 B 21 45
6 B 22 Place4 45
7 B Place3 45
8 B 22 Place2 45
9 C 21 48
10 C 45
11 C 21 45
12 C 22 47

I am doing out an advanced filter based on the Age, Place and Mark
columns (all the 3 columns) and getting the unique combination of
values in separate tabs in the same workbook.

But this advancedfilter method fails when it is finding out an empty
cell value. Instead of copying the unique row to the target tab it is
copying the whole data into the target tab. The macro code is as
follows.

Sub GetUniqueAndMoveToTab()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range

Dim r1 As Integer, r2 As Integer
Dim c As Range, d As Range

Dim titSheet As String
Dim cval As String, dval As String, eval As String

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set rng = Range("Database") ' Database is the predefined Name for
the Range of data

ws1.Columns("C:C").AdvancedFilter action:=xlFilterCopy, _
COPYTORANGE:=Range("J1"), UNIQUE:=True
r1 = Cells(Rows.Count, "J").End(xlUp).Row

ws1.Columns("D").AdvancedFilter action:=xlFilterCopy, _
COPYTORANGE:=Range("K1"), UNIQUE:=True
r2 = Cells(Rows.Count, "K").End(xlUp).Row

ws1.Columns("E:E").AdvancedFilter action:=xlFilterCopy, _
COPYTORANGE:=Range("I1"), UNIQUE:=True
r3 = Cells(Rows.Count, "I").End(xlUp).Row

Range("L1").Value = Range("C1").Value
Range("M1").Value = Range("D1").Value
Range("N1").Value = Range("E1").Value

For Each c In ws1.Range("J2:J" & r1)
ws1.Range("L2").Value = c.Value

For Each d In ws1.Range("K2:K" & r2)
ws1.Range("M2").Value = d.Value

For Each e In ws1.Range("I2:I" & r3)
ws1.Range("N2").Value = e.Value

Set wsNew = Sheets.Add

If IsEmpty(c.Value) = True Then cval = "Blank" Else
cval = c.Value
If IsEmpty(d.Value) = True Then dval = "Blank" Else
dval = d.Value
If IsEmpty(e.Value) = True Then eval = "Blank" Else
eval = e.Value

titSheet = cval & "" & dval & "" & eval

wsNew.Move AFTER:=Worksheets(Worksheets.Count)
wsNew.Name = titSheet

rng.AdvancedFilter action:=xlFilterCopy, _
criteriarange:=Sheets("Sheet1").Range("L1:N2"),
_
COPYTORANGE:=wsNew.Range("A1"), UNIQUE:=True

Next e
Next d
Next c

ws1.Select
ws1.Columns("J:N").Delete

End Sub

This is the code I have written for getting the unique records based on
3 columns and put into the new tabs.

Any Suggestions?

Thanx in Advance,
Regards,
Bala

 

[Tom Ogilvy]

try using a pivot table with your three columns as row fields. Get a count
on Mark in the data field.

then "clean-up" the results, i.e.
select the pivot table, do edit=>copy, then edit=>Paste Special Values to
make it no longer a pivot table, then manipulate the data.

 

[kounoike]

I'm not sure what you mean the unique records based on 3 columns.
so, this is not what you want, but this one would show only data in
which a result of combination of column C, D, E is the unique.

Sub GetUnique()
Dim trng As Range, afrng As Range
Dim tmprng As Range, ctrng As Range
Dim strc As Long, ltrc As Long
Dim stlc As Long, ltlc As Long
Dim strads As String
Dim i As Long, co As Long

On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0

Set trng = ActiveCell
Set afrng = trng.CurrentRegion
If afrng.Count = 1 Or IsEmpty(trng) Then
MsgBox "Select a cell in the Table"
Exit Sub
End If
strc = afrng.Row
ltrc = afrng.Rows.Count + strc - 1
stlc = afrng.Column
ltlc = afrng.Columns.Count + stlc - 1
co = Cells(strc, Cells.Columns.Count) _
.End(xlToLeft).Column
Columns(co + 1).Resize(, Cells.Columns.Count - co) _
.Delete
Set trng = Cells(strc, trng.Column)
If Cells(strc, ltlc).Value = "CTEMP" Then
MsgBox "Delete Temporary columns"
Exit Sub
End If
Set tmprng = Cells(strc, ltlc + 1)
tmprng.Value = "CTEMP"
For i = 2 To ltrc - strc + 1
tmprng(i, 1) = Cells(i, "C") & Chr(5) _
& Cells(i, "D") & Chr(5) _
& Cells(i, "E") '<<===Change here
Next
strads = Range(tmprng(2, 1), _
tmprng(ltrc - strc + 1, 1)).Address
Set afrng = Range(tmprng, Cells(ltrc, ltlc + 1))
Set ctrng = Cells(strc, ltlc + 3)
ctrng(2, 1).Formula = "=countif(" & strads & "," & _
Cells(strc + 1, tmprng.Column) _
.AddressLocal(RowAbsolute:=False) & ")=1"
afrng.AdvancedFilter _
Action:=xlFilterInPlace, _
CriteriaRange:=ctrng.Resize(2, 1)
End Sub

keizi