Move or Copy Duplicate Rows to Difference Sheet
Hi Guys
I'm new here. Anyway let's go straight to the above matter. I have below macro from Kris ( Krishnakumar ) which I believe he is also a Moderator or something here. Anyway the script that he gave me , was perfect at that point of time but I have another issue now. I am currently using Excel 2010 and I have a data that goes up to 856756 lines where I need to check for duplicate and maintain only unique numbers. There's another criteria where the unique number should based on the condition where the Active Date will be the latest date. Script that provided by Kris as below :-
Code:
Sub kTest_v2()
Dim ka, k(), q(), n As Long, i As Long, c As Long, j As Long
With ActiveSheet
ka = .UsedRange
ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))
ReDim q(1 To UBound(ka, 1), 1 To UBound(ka, 2))
With CreateObject("scripting.dictionary")
For i = UBound(ka, 1) To 2 Step -1
If ka(i, 4) <> vbNullString Then
If Not .exists(LCase$(ka(i, 4))) Then
n = n + 1:
For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
.Add LCase$(ka(i, 4)), Nothing
Else
j = j + 1
For c = 1 To UBound(ka, 2): q(j, c) = ka(i, c): Next
End If
End If
Next
End With
If n > 0 Then
.Cells(2, 1).Resize(UBound(ka, 1) - 1, UBound(ka, 2)).ClearContents
.Cells(2, 1).Resize(n, UBound(ka, 2)).Value = k
End If
End With
MsgBox j
If j > 0 Then
With Sheets("Sheet2") '<== adjust to suit
.Cells(1).Resize(, UBound(ka, 2)).Value = Application.Index(ka, 1, 0)
.Cells(2, 1).Resize(j, UBound(ka, 2)).Value = q
End With
End If
End Sub
My issues with the above code is, when I use it, there will be an error prompt "Run time Error = 7" " Out of Memory" . Anyone have an ideas on how to solve this?
