Hi Everyone,
Thanks for your help. I am a newbie, but I have learned alot in the
past couple of weeks.
This is the problem.
I have a spreadsheet of employee names and projects with durations in
months. Now, I would like to delete the
employees that are supporting multiple projects and only keep the row
with the longest duration.
I found this little macro on the internet and it works great as far as
the deleting the duplicate rows. However, it's not keeping the row
with the longest duration that I want.
For example,
Column A Column G Column J Column
K
=sum in months
Manager1 EmployeeName1 Project 1 9
John Smith Edwards, Jim Google1 10
John Smith Edwards, Jim Google2 12
John Smith Edwards, Jim Google3 15
So, in this example Jim Edwards is supporting 2 projects. I would
like to keep the row that has him support Google2 for 15 months and
delete the Google1 and Google2 rows.
Can someone please help me?
Public Sub DeleteDuplicateRows()
Application.ScreenUpdating = False
Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range
Dim LSheetD As String
'Set up names of sheets
LSheetD = "Dept"
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets(LSheetD).Select
Columns("G:G").Select
Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")
N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = Rng.Cells(R, 1).Value
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(Rng.Columns(1),
vbNullString) > 1 Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Else
If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1
Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
--~--~---------~--~----~------------~-------~--~----~
----------------------------------------------------------------------------------
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
-~----------~----~----~----~------~----~------~--~---
