Hi Everyone,
Thanks for the help on my last question. I would like to expand on
that macro slightly. I have tried a couple of things and they are not
working.
Here's what I would like to do. Sample data is shown below.
1). I would like to keep the duplicate TBD that are shown in Column
A. Right now, the macro is deleting all duplicates. I tried to add a
simple if statement above the delete row and it didn't work. Syntax
error.
2). I would like to insert a column after Column B that has a Y in it
to identify the employees who support multiple projects.
Data starts on A6.
Usage: FilterDelete (ActiveSheet.Range("A6"))
SAMPLE DATA BEFORE
Column A Column B Column C
Employee1 ProjectName1 10
Employee1 ProgramName2 20
Emplyee2 ProjectName3 5
Emplyee2 ProjectName10 50
Emplyee4 ProjectName3 30
TBD ProjectName5 7
TBD ProjectName6 8
SAMPLE DATA AFTER
Column A Column B Column C Column D
Employee1 ProjectName1 Y 20
Emplyee2 ProjectName10 Y 50
Emplyee4 ProjectName3 30
TBD ProjectName5 7
TBD ProjectName6 8
Function FilterDelete(TargetColumn As Range)
Dim lLastRow As Long
Dim lLastCol As Long
'Check if multiple columns provided and exit if so
If TargetColumn.Columns.Count <> 1 Then Exit Function
With TargetColumn.Parent
'Determine last row and last column
lLastRow = .Cells.Find(What:="*", After:=.Range("A1"),
LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
lLastCol = .Cells.Find(What:="*", After:=.Range("A1"),
LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Column
'Set up an index column of ascending numbers after the last column
.Cells(6, lLastCol + 1).Value = 1
.Range(.Cells(7, lLastCol + 1), .Cells(lLastRow, lLastCol +
1)).FormulaR1C1 = "=R[-1]C+1"
.Columns(lLastCol + 1).Cells.Copy
.Columns(lLastCol + 1).Cells.PasteSpecial Paste:=xlValues
'Sort the records by the column specified in ascending order
.Range(.Cells(6, 1), .Cells(lLastRow, lLastCol + 1)).Sort _
Key1:=TargetColumn, Order1:=xlAscending, _
Key2:=.Columns(lLastCol + 1)
'Set up an formula column at end to determine if each rows record
matches
'the previous rows record. If so, mark it 0, otherwise 1
.Cells(6, lLastCol + 2).Value = 0
.Range(.Cells(7, lLastCol + 2), .Cells(lLastRow, lLastCol +
2)).FormulaR1C1 = _
"=if(RC[" & TargetColumn.Column - (lLastCol + 2) & "]=R[-1]C["
& TargetColumn.Column - (lLastCol + 2) & "],1,0)"
.Columns(lLastCol + 2).Cells.Copy
.Columns(lLastCol + 2).Cells.PasteSpecial Paste:=xlValues
'Sort the records by the match column. Eliminates complex ranges
in large data sets that create errors
.Range(.Cells(6, 1), .Cells(lLastRow, lLastCol + 2)).Sort _
Key1:=.Cells(1, lLastCol + 2)
'Autofilter and delete all cells showing a 1 as they are duplicate
values
With .Range(.Cells(1, 1), (.Cells(lLastRow, lLastCol + 2)))
.AutoFilter
.AutoFilter field:=lLastCol + 2, Criteria1:="1"
End With
.Range(.Cells(7, 1), .Cells(lLastRow, lLastCol + 2)).SpecialCells
(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False
'Resort the data back to the original order
'.Range(.Cells(6, 1), .Cells(.Rows.Count, lLastCol + 2).End
(xlUp)).Sort _
Key1:=.Cells(6, lLastCol + 1)
'Remove index columns created for duplicate removal
.Range(.Cells(1, lLastCol + 1), .Cells(1, lLastCol +
2)).EntireColumn.Delete
End With
End Function
--~--~---------~--~----~------------~-------~--~----~
----------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
<><><><><><><><><><><><><><><><><><><><><><>
HELP US GROW !!
We reach over 6,500 subscribers worldwide and receive many nice notes about the
learning and support from the group. Our goal is to have 10,000 subscribers by
the end of 2009. Let friends and co-workers know they can subscribe to group at
http://groups.google.com/group/excel-macros/subscribe
-~----------~----~----~----~------~----~------~--~---
