Help to modify a macro for deleting rows based on two or more colu

[Monomeeth]

Hello

I have a macro I have been using to delete duplicate rows which contain the
same value in two columns. This works well, as long as I manually sort Column
A in ascending order first, before running the macro. The code is as follows:

--------------------------

Sub DeleteDuplicates2Columns()
Dim LR As Long, i As Long
Application.ScreenUpdating = False

LR = Range("A" & Rows.Count).End(xlUp).Row

For i = LR To 2 Step -1
If Cells(i, "A") = Cells(i - 1, "A") And _
Cells(i, "L") = Cells(i - 1, "L") Then _
Rows(i).Delete xlShiftUp
Next i

Application.ScreenUpdating = True
End Sub

--------------------------

As you can see, the above code removes duplicate rows if they contain
matching data in columns A and L. In the past if I have needed to change this
to remove duplicate rows based on matching values in different columns I just
modified the code. However, I now want to share this with other users who
have no idea about code, so my preference would be to have an input box where
they can just select the columns.

Also, in the past I have just added another line of code if I wanted the
macro to do the comparisons across three columns. For example:

For i = LR To 2 Step -1
If Cells(i, "A") = Cells(i - 1, "A") And _
Cells(i, "L") = Cells(i - 1, "L") Then _
Rows(i).Delete xlShiftUp
Next i

BECOMES

For i = LR To 2 Step -1
If Cells(i, "A") = Cells(i - 1, "A") And _
Cells(i, "K") = Cells(i - 1, "K") And _
Cells(i, "L") = Cells(i - 1, "L") Then _
Rows(i).Delete xlShiftUp
Next i

So, is there any way to do this in a user-friendly manner for other users?
For instance, using an input box to specify how many columns the user wants
to interrogate and then having the macro display enough input boxes for the
user to actually specify the columns. Perhaps this could work if the number
of columns were restricted to a maximum of 5?

Just out of curiosity, can someone explain why I have to sort Column A into
ascending order first before running the macro? Is this macro limited in some
way so that it only compares the rows one at a time adjacent to one another?
If so, how could I modify the macro so that this isn't the case? Perhaps it
would be easier to just get the macro to sort Column A first before doing
anything else.

Sorry for the long post. Hope this all makes sense. Any help would be
greatly appreciated!

Thanks!

Joe.

 

[Gary Keramidas]

it appears to do what you want here, but i don't have your dataset.

anyway, i would qualify all of the ranges and use .value for the cell
references. i usually do my if's on different lines so it's easier for me read
and to create breakpoints


Sub DeleteDuplicates2Columns()
Dim LR As Long, i As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1")
LR = Range("A" & Rows.Count).End(xlUp).Row

For i = LR To 2 Step -1
If ws.Cells(i, "A").Value = ws.Cells(i - 1, "A").Value And ws.Cells(i,
"L").Value = ws.Cells(i - 1, _
"L").Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End Sub

 

[Gary Keramidas]

and watch for wordwrap, too. one line split. the following will split, but it
goes on one line

If ws.Cells(i, "A").Value = ws.Cells(i - 1, "A").Value And ws.Cells(i,>
"L").Value = ws.Cells(i - 1, _

 

[Per Jessen]

Hi Joe

This solution prompt for # of columns to compare (2-5) and then I use one
input box for the user to enter columns to compare. Each column label has to
be seperated by a comma.

Sub DeleteDuplicates2Columns()
Dim LR As Long, i As Long
Dim RowComp
Dim ColToCompare As String
Dim ColArr

Application.ScreenUpdating = False

LR = Range("A" & Rows.Count).End(xlUp).Row
Do
RowComp = InputBox("Enter # of columns to compare (2-5) ", _
"Delete Duplicates", 2)
If RowComp = "" Then Exit Sub
Loop Until RowComp >= 2 And RowComp <= 5
ColToCompare = InputBox("Enter column labels of " & _
RowComp & " columns to compare." & vbLf & vbLf & _
"Seperate each column label by a comma, eg. 'A,L'", "Columns to
compare")
If ColToCompare = "" Then Exit Sub
ColArr = Split(ColToCompare, ",")
If UBound(ColArr) + 1 <> RowComp Then
msg = MsgBox("Wrong # of columns entered!" & vbLf & vbLf & _
"Ending this macro!", vbExclamation + vbOKOnly, "Input error")
Exit Sub
End If
'--------------
'Sort on Col A
'--------------
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

'----------------------
'Compare and delete
'----------------------
Select Case ColToCompare
Case 2
For i = LR To 2 Step -1
If Cells(i, ColArr(0)) = Cells(i - 1, ColArr(0)) And _
Cells(i, ColArr(1)) = Cells(i - 1, ColArr(1)) Then
Rows(i).Delete xlShiftUp
End If
Next i
Case 3
For i = LR To 2 Step -1
If Cells(i, ColArr(0)) = Cells(i - 1, ColArr(0)) And _
Cells(i, ColArr(1)) = Cells(i - 1, ColArr(1)) And _
Cells(i, ColArr(2)) = Cells(i - 1, ColArr(2)) Then

Rows(i).Delete xlShiftUp
End If
Next i
Case 4
For i = LR To 2 Step -1
If Cells(i, ColArr(0)) = Cells(i - 1, ColArr(0)) And _
Cells(i, ColArr(1)) = Cells(i - 1, ColArr(1)) And _
Cells(i, ColArr(2)) = Cells(i - 1, ColArr(2)) And _
Cells(i, ColArr(3)) = Cells(i - 1, ColArr(3)) Then

Rows(i).Delete xlShiftUp
End If
Next i
Case 5
For i = LR To 2 Step -1
If Cells(i, ColArr(0)) = Cells(i - 1, ColArr(0)) And _
Cells(i, ColArr(1)) = Cells(i - 1, ColArr(1)) And _
Cells(i, ColArr(2)) = Cells(i - 1, ColArr(2)) And _
Cells(i, ColArr(3)) = Cells(i - 1, ColArr(3)) And _
Cells(i, ColArr(4)) = Cells(i - 1, ColArr(4)) Then

Rows(i).Delete xlShiftUp
End If
Next i
End Select
Application.ScreenUpdating = True
End Sub

Regards,
Per

 

[joel]

First, the code you have posted will not work because you need to sor
by all columns you are comparing.

Suppose you have two columns of data as shown below

Col D Col E
A X
A Y
A X


If you sort only by Column A you will not remove all the duplicates.


If you were writing generic code to do 5 columns you would need t
specify up to 5 column. You also would want to return the data to it
original order so not to confuse people. So you need to add a ne
column containing the original row number and then at the end sort b
the new column and then delete the new column.


Try this generic code. It will work with any number of columns

Sub DeleteDuplicates2Columns()
Dim Col As Variant
Dim ColNum As Long
Dim LastRow As Long
Dim Response As String
Dim RowCount As Long
Dim SelectCols As Variant

Application.ScreenUpdating = False

Response = InputBox("Enter 5 Column Letters to compare seperated b
commas" & vbCrLf & _
"[ie A,D,E]")

SelectCols = Split(Response, ",")

'covert column letters to numbers
For Each Col In SelectCols
ColNum = Val(Range(Trim(Col) & "1").Column)
Col = ColNum
Next Col


LastRow = Range("A" & Rows.Count).End(xlUp).Row

'Add row number to each row
For RowCount = 1 To LastRow
Range("IV" & RowCount) = RowCount
Next RowCount

'sort by each column
For Each Col In SelectCols
Rows("1:" & LastRow).Sort _
header:=xlYes, _
key1:=Cells(1, Col), _
order1:=xlAscending
Next Col

For RowCount = LastRow To 2 Step -1
Match = True
For Each Col In SelectCols
If Cells(RowCount, Col) <> Cells(RowCount - 1, Col) Then
Match = False
Exit For
End If
Next Col

If Match = True Then
Rows(RowCount).Delete
End If
Next RowCount

'return order to original order
Rows("1:" & LastRow).Sort _
header:=xlYes, _
key1:=Range("IV1"), _
order1:=xlAscending
'delete column with row numbers
Columns("IV").Delete

Application.ScreenUpdating = True
End Su

 

[malstan]

First, the code you have posted will not work because you need to sor
by all columns you are comparing.

Suppose you have two columns of data as shown below

Col D Col E
A X
A Y
A X


If you sort only by Column A you will not remove all the duplicates.


If you were writing generic code to do 5 columns you would need t
specify up to 5 column. You also would want to return the data to it
original order so not to confuse people. So you need to add a ne
column containing the original row number and then at the end sort b
the new column and then delete the new column.


Try this generic code. It will work with any number of columns

Sub DeleteDuplicates2Columns()
Dim Col As Variant
Dim ColNum As Long
Dim LastRow As Long
Dim Response As String
Dim RowCount As Long
Dim SelectCols As Variant

Application.ScreenUpdating = False

Response = InputBox("Enter 5 Column Letters to compare seperated b
commas" & vbCrLf & _
"[ie A,D,E]")

SelectCols = Split(Response, ",")

'covert column letters to numbers
For Each Col In SelectCols
ColNum = Val(Range(Trim(Col) & "1").Column)
Col = ColNum
Next Col


LastRow = Range("A" & Rows.Count).End(xlUp).Row

'Add row number to each row
For RowCount = 1 To LastRow
Range("IV" & RowCount) = RowCount
Next RowCount

'sort by each column
For Each Col In SelectCols
Rows("1:" & LastRow).Sort _
header:=xlYes, _
key1:=Cells(1, Col), _
order1:=xlAscending
Next Col

For RowCount = LastRow To 2 Step -1
Match = True
For Each Col In SelectCols
If Cells(RowCount, Col) <> Cells(RowCount - 1, Col) Then
Match = False
Exit For
End If
Next Col

If Match = True Then
Rows(RowCount).Delete
End If
Next RowCount

'return order to original order
Rows("1:" & LastRow).Sort _
header:=xlYes, _
key1:=Range("IV1"), _
order1:=xlAscending
'delete column with row numbers
Columns("IV").Delete

Application.ScreenUpdating = True
End Sub

Hi there this was really great and as a newbie assisted greatly . On
question is would it be possible to addapt this script to only delet
rows that have zero's in the nominated columns? Thanks in advanc