It needed a few adjustments:
Sub FilterDuplicateRows()
Dim i As Long
Dim c As Long
Dim n As Long
Dim LR As Long
Dim LC As Long
Dim rngLast As Range
Dim arr
Dim arr2
Dim strTemp As String
On Error GoTo ERROROUT 'for cancelled input
Set rngLast = _
Application.InputBox(Prompt:="Choose the last cell of the range to
filter", _
Title:="clear duplicate rows", _
Default:=Cells(1).End(xlDown).End(xlToRight).Addre ss,
_
Type:=8)
On Error GoTo 0
Application.ScreenUpdating = False
Cells(1).EntireColumn.Insert
LR = rngLast.Row
LC = rngLast.Column
ReDim arr2(1 To LR, 1 To LC - 1)
arr = Range(Cells(1), Cells(LR, LC))
For i = 1 To LR
strTemp = ""
For c = 2 To LC
strTemp = strTemp & arr(i, c)
Next
arr(i, 1) = strTemp
Next
procSort2D arr, "A", 1
For c = 2 To LC
arr2(1, c - 1) = arr(1, c)
Next
n = 1
For i = 2 To LR
If arr(i, 1) < arr(i - 1, 1) Then
n = n + 1
For c = 2 To LC
arr2(n, c - 1) = arr(i, c)
Next
End If
Next
Range(Cells(1), Cells(LR, LC)).Clear
Range(Cells(1), Cells(n, LC - 1)) = arr2
Application.ScreenUpdating = True
ERROROUT:
End Sub
RBS
"RB Smissaert" wrote in message
...
Try something like this:
Sub FilterDuplicateRows()
Dim i As Long
Dim c As Long
Dim n As Long
Dim LR As Long
Dim LC As Long
Dim rngLast As Range
Dim arr
Dim arr2
Dim strTemp As String
Set rngLast = _
Application.InputBox(Prompt:="Choose the last cell of the range to
filter", _
Title:="clear duplicate rows", _
Type:=8)
Application.ScreenUpdating = False
Cells(1).EntireColumn.Insert
LR = rngLast.Row
LC = rngLast.Column
ReDim arr2(1 To LR, 1 To LC - 1)
arr = Range(Cells(1), Cells(LR, LC))
For c = 2 To LC
arr2(1, c - 1) = arr(1, c)
Next
For i = 1 To LR
strTemp = ""
For c = 2 To LC
strTemp = strTemp & arr(i, c)
Next
arr(i, 1) = strTemp
Next
procSort2D arr, "A", 1
n = 1
For i = 2 To LR
If arr(i, 1) < arr(i - 1, 1) Then
n = n + 1
For c = 2 To LC
arr2(n, c - 1) = arr(i, c)
Next
End If
Next
Range(Cells(1), Cells(LR, LC)).Clear
Range(Cells(1), Cells(n, LC - 1)) = arr2
Application.ScreenUpdating = True
End Sub
Function procSort2D(ByRef avArray, _
ByRef sOrder As String, _
ByRef iKey As Long, _
Optional ByRef iLow1 As Long = -1, _
Optional ByRef iHigh1 As Long = -1) As Boolean
Dim iLow2 As Long
Dim iHigh2 As Long
Dim i As Long
Dim vItem1 As Variant
Dim vItem2 As Variant
On Error GoTo ERROROUT
If iLow1 = -1 Then
iLow1 = LBound(avArray, 1)
End If
If iHigh1 = -1 Then
iHigh1 = UBound(avArray, 1)
End If
'Set new extremes to old extremes
iLow2 = iLow1
iHigh2 = iHigh1
'Get value of array item in middle of new extremes
vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
'Loop for all the items in the array between the extremes
While iLow2 < iHigh2
If sOrder = "A" Then
'Find the first item that is greater than the mid-point item
While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend
'Find the last item that is less than the mid-point item
While avArray(iHigh2, iKey) vItem1 And iHigh2 iLow1
iHigh2 = iHigh2 - 1
Wend
Else
'Find the first item that is less than the mid-point item
While avArray(iLow2, iKey) vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend
'Find the last item that is greater than the mid-point item
While avArray(iHigh2, iKey) < vItem1 And iHigh2 iLow1
iHigh2 = iHigh2 - 1
Wend
End If
'If the two items are in the wrong order, swap the rows
If iLow2 < iHigh2 Then
For i = LBound(avArray) To UBound(avArray, 2)
vItem2 = avArray(iLow2, i)
avArray(iLow2, i) = avArray(iHigh2, i)
avArray(iHigh2, i) = vItem2
Next
End If
'If the pointers are not together, advance to the next item
If iLow2 <= iHigh2 Then
iLow2 = iLow2 + 1
iHigh2 = iHigh2 - 1
End If
Wend
'Recurse to sort the lower half of the extremes
If iHigh2 iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2
'Recurse to sort the upper half of the extremes
If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1
procSort2D = True
Exit Function
ERROROUT:
procSort2D = False
End Function
RBS
"luu980" wrote in
message ...
Does anyone know of a macro to remove identical rows in excel?
That is, the macro is to first *_compare_rows_against_one_another_*
then delete the identical ones, leaving only one copy.
I have found many macros that delete rows, but it only compares values
in a single column. This is NOT what I need.
What I need is this, for example:
aaaa bbbb cccc dddd
aaaa bbbb zzzzz dddd
aaaa rrrrrr cccc dddd
mmm bbbb cccc dddd
aaaa bbbb cccc dddd
aaaa bbbb zzzzz dddd
aaaa bbbb zzzzz dddd
Leaving me:
aaaa bbbb cccc dddd
aaaa bbbb zzzzz dddd
aaaa rrrrrr cccc dddd
mmm bbbb cccc dddd
--
luu980
------------------------------------------------------------------------
luu980's Profile:
http://www.excelforum.com/member.php...fo&userid=6931
View this thread:
http://www.excelforum.com/showthread...hreadid=520376