Copy/Paste unique rows based on multiple criteria

[Beatrix]

Hi Everyone

I have got a spreadsheet with multiple records and I need to copy /paste the unique rows into a seperate spreadsheet.

The condition is if the ID and the postcode is the same then copy the one updated with most recent month even total is less than the others.

For example, There are 4 records with the same ID and the same postcode;

Record1: up to date till Sep-16 with total 47
Record2: up to date till Nov-16 with total 47
Record3: up to date till Aug-15 with total 30
Record4: up to date till Sep-16 with total 50

In this case I need to copy/paste Record 2 only as it's up to date until Nov-16.

I really appreciate if anyone could help me with this please? I attached the test file with before/after tabs.

Cheers
B.

[offthelip]

try this:

[vba]Sub movelongest()
Dim counter() As Integer


With Worksheets("Before")
lastrow = .Cells(Cells.Rows.count, "A").End(xlUp).Row
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 55))
End With
With Worksheets("After")
.Range(.Cells(1, 1), .Cells(lastrow, 55)) = ""
outarr = .Range(.Cells(1, 1), .Cells(lastrow, 55))
End With
ReDim counter(1 To lastrow)
' calculate the number of updates for each line
For j = 2 To lastrow
For k = 7 To 54
If (IsEmpty(inarr(j, k))) Then
counter(j) = k - 1
Exit For
End If
Next k
Next j





outi = 2
ID = 0
PC=""
firsttime = True
For I = 2 To lastrow
If ID = inarr(I, 1) and PC = inarr(I,3) Then
If counter(I) > cnt Then
cnt = counter(I)
indi = I
End If
Else
' output llast longest
If Not (firsttime) Then

For k = 1 To 55
outarr(outi, k) = inarr(indi, k)
Next k
outi = outi + 1
End If
' reinitialise
firsttime = False
ID = inarr(I, 1)
PC=inarr(I,3)
cnt = counter(I)
indi = I
End If
Next I


With Worksheets("After")
.Range(.Cells(1, 1), .Cells(lastrow, 55)) = outarr
End With
End Sub


[/vba]

[Beatrix]

Hi offthelip,

Thanks very much for your reply.

I used the script which works great however if there are duplicates then it doesn't work. Example ID 1279 and ID 2154.

I was wondering if it's possible to add two more criteria as below?

- If the records has duplicates just copy/paste one of them.
-If the ID, the postcode and the latest month are the same then whichever has the max number of total should be copied to "After" worksheet.

Cheers
B.

[offthelip]

Hi Beatrix,
the code does cater for dupllcates but only if the occur next to each other, the problem with ID 1279 is that the post code changes between row 4 and row 5 and then between row 5 and 6 even though row 4 and 6 are the same. Is there any possibility of sorting the data on columns A and C before you start? This would solve the problem without needing to recode it?
You don't have a date in the current data , but this can be added easily, provided the data is sorted.
Note if you don't sort the data it gets a lot harder to run through it to find duplicates.

[Beatrix]

Ah I see! Many Thanks for your quick response offthelip..It makes sense..I will sort the data based on ID and Postcode then will re-run the script...


Thanks a million.
B.

[snb]

I'd use:

Sub M_snb()
   sn = Sheets("before").Cells(1).CurrentRegion
   
   With CreateObject("scripting.dictionary")
      For j = 2 To UBound(sn)
         y = 0
         For jj = 7 To UBound(sn, 2) - 1
           If Abs(jj * (sn(j, jj) <> "")) > y Then y = jj
         Next
        If y > .Item(sn(j, 1) & sn(j, 3)) Then
           .Item(sn(j, 1) & sn(j, 3)) = y
           .Item(sn(j, 1) & sn(j, 3) & "_") = Application.Index(sn, j)
        End If
      Next
      
      sp = Filter(.keys, "_", 0)
      For Each it In sp
        .Remove it
      Next
      
      Sheets("after").Cells(60, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
   End With
End Sub

[rlv]

Sub DoSomething()
    Dim WS As Worksheet, WS2 As Worksheet
    Dim ColRange As Range
    Dim R As Range
    Dim I As Long
    Dim KeyStr As String, ItemStr As String
    Dim LastUpdateCol As Long
    Dim SD As Object

    Set SD = CreateObject("Scripting.Dictionary")
    Set WS = Worksheets("Before")
    Set WS2 = Worksheets("After")

    With WS
        Set ColRange = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With

    For Each R In ColRange
        With Application.Intersect(R.EntireRow, WS.UsedRange)
            LastUpdateCol = Cells(.Row, .Columns.Count - 1).End(xlToLeft).Column
        End With

        KeyStr = R.Value & R.Offset(0, 2).Value
        ItemStr = CStr(LastUpdateCol)

        If Not SD.Exists(KeyStr) Then
            SD.Add Key:=KeyStr, Item:=ItemStr
        Else
            If CLng(SD.Item(KeyStr)) < LastUpdateCol Then
                SD.Remove (KeyStr)
                SD.Add Key:=KeyStr, Item:=ItemStr
            End If
        End If
    Next R

    WS2.Cells.Clear
    WS.Rows(1).Copy WS2.Rows(1)
    I = 2
    For Each R In ColRange
        With Application.Intersect(R.EntireRow, WS.UsedRange)
            LastUpdateCol = Cells(.Row, .Columns.Count - 1).End(xlToLeft).Column
        End With
        
        KeyStr = R.Value & R.Offset(0, 2).Value
        ItemStr = CStr(LastUpdateCol)

        If CLng(SD.Item(KeyStr)) = LastUpdateCol Then
            R.EntireRow.Copy WS2.Rows(I)
            SD.Remove (KeyStr)
            I = I + 1
        End If
    Next R
End Sub

[mdmackillop]

My tuppence-worth

Option Explicit
Sub Test()
    Dim LR As Long, i As Long, col As Long, x As Long
    Dim tot As Long
    Dim dic, a
    Dim txt As String
    Dim wsS As Worksheet, wsT As Worksheet
    Dim cel As Range
    
    Set wsS = Sheets("Before")
    Set dic = CreateObject("Scripting.dictionary")
    On Error Resume Next
    
    'These lines ensure cells are empty as test gave odd results; can be deleted
    For Each cel In wsS.UsedRange
    If Len(cel) = 0 Then cel.ClearContents
    Next
   
    'Dubug stuff
    wsS.UsedRange.Offset(1).Cells.Interior.ColorIndex = xlNone
    Application.DisplayAlerts = False
    Sheets("Test").Delete
    Application.DisplayAlerts = True
    
     'Delete to here
     
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LR
        txt = (wsS.Cells(i, 1) & wsS.Cells(i, 3))
        col = wsS.Cells(i, "BC").End(xlToLeft).Column
        tot = wsS.Cells(i, "BC")
        If dic.exists(txt) Then
            If col > CLng(Split(dic(txt), "-")(1)) Then dic(txt) = i & "-" & col & "-" & tot
            If tot > CLng(Split(dic(txt), "-")(2)) Then dic(txt) = i & "-" & col & "-" & tot
        Else
            dic.Add txt, i & "-" & col & "-" & tot
        End If
    Next i
    
    Set wsT = Sheets.Add
    wsT.Name = "Test"
    wsS.Rows(1).Copy wsT.Cells(1, 1)
    i = 2
    For Each a In dic.keys
        x = Split(dic(a), "-")(0)
        wsS.Rows(x).Copy wsT.Cells(i, 1)
        i = i + 1
    Next
    dic.RemoveAll
End Sub

[Beatrix]

Thank you so much everyone for replying my thread. All scripts are working perfect. You helped me to save lots of time

Cheers
B.