PDA

View Full Version : [SOLVED] Copy/Paste unique rows based on multiple criteria



Beatrix
04-18-2017, 09:13 AM
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
04-18-2017, 04:30 PM
try this:

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

Beatrix
04-20-2017, 04:00 AM
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
04-20-2017, 05:17 AM
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
04-20-2017, 06:19 AM
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
04-20-2017, 07:03 AM
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
04-20-2017, 07:50 AM
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
04-20-2017, 09:33 AM
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
04-24-2017, 06:41 AM
Thank you so much everyone for replying my thread. All scripts are working perfect. You helped me to save lots of time :)

Cheers
B.