How to copy the row from duplicate rows if the conditions are met through VBA

M

Maruthiveer

New Member
Joined
Apr 12, 2020
Messages
15
Office Version
  1. 2016
  2. 2013
  3. 2011
  4. 2010
  5. 2007
Platform
  1. Windows
  2. Mobile
I have an excel master sheet (output) with columns "A" to "AL", The column "A" will have ID's,column "k" has date , column "AB" have sequence(0,1,2,3,4..) and column "AL" have row count(2,3,4,5,6..). The column A will have same values sometimes i.e,(Duplicate values). I need to copy the entire row through the below conditions:

if row count(AB) =2
check for any duplicate ID's in (coloumn "A")
1.if no duplicate ID's found then copy that row and paste it in sheet2 ( Final Output).
2.If Duplicate ID's found , copy the row with the highest sequence number (AB) to sheet 2.
3.If Duplicate ID's found and the sequence number is also same then copy the row with the date(K),whichever date is recent one that row should be copied and paste in the sheet2.
same process for the rowcount= 3,4,5,..

can any one can help me ..
 
Sort by date Sort by votes
sorry about the errors try this, I have tested it so it appears to work if I have understood what you want:
VBA Code: 
Sub test()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 38)) ' pick A1 to Al lastrow
ReDim outarr(1 To lastrow, 1 To 38)
indi = 2
For rowcnt = 2 To 30
    For i = 2 To lastrow
        If inarr(i, 38) = rowcnt Then ' check is AL = rowcnt your requirements are ambiguous I presume row count is in AL
            currentid = inarr(i, 1)
            copi = i
            First = True
            For j = i + 1 To lastrow
                ' look for duplicates
                If inarr(j, 1) = currentid And inarr(j, 1) <> "" Then
                   ' If First Then ' check if it is the first duplicate
                    ' check sequnce number AB
                        If inarr(j, 28) > inarr(copi, 28) Then
                            inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                            copi = j
                        Else
                        ' check if sequnce number equal
                            If inarr(j, 28) = inarr(copi, 28) Then
                            ' check dates
                                If inarr(j, 11) > inarr(copi, 11) Then
                                inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                                copi = j
                                End If
                            End If
                        End If
                   ' End If
                End If
            Next j
            ' copy row
            If inarr(copi, 1) <> "" Then
                For k = 1 To 38
                outarr(indi, k) = inarr(copi, k)
                Next k
                inarr(copi, 1) = ""
                indi = indi + 1
            End If
        End If
    
    Next i
Next rowcnt
With Worksheets("Sheet2")
Range(.Cells(1, 1), .Cells(indi, 38)) = outarr
End With

End Sub
 
Upvote 0

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
yeah its working Fine for row count values 2 , but for row count 3 it gave me two results .

For reference:

Masterdata:
IDEff DateSequenceRow Count
72732020-03-20
0​
2​
72732020-03-23
0​
2​
48882020-03-16
0​
2​
48882020-03-16
1​
2​
60802020-03-10
0​
2​
60802020-03-10
10​
2​
39692020-03-17
0​
3​
39692020-03-17
10​
3​
39692020-03-19
0​
3​


Output:
7273​
3/23/2020​
0​
2​
4888​
3/16/2020​
1​
2​
6080​
3/10/2020​
10​
2​
3969​
3/17/2020​
10​
3​
3969​
3/19/2020​
0​
3​


Irrespective of row count i want only one Id to be copied. It is working fine for row count 2 . it is fulfilling my requirement . can you look why it we are getting different output for row cont 3 .

Thanks
 
Upvote 0
Interesting, I have found the bug, it was caused by my code not catering for the sequence numbers not being in order, this should fix it:
VBA Code: 
Sub test()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 38)) ' pick A1 to Al lastrow
ReDim outarr(1 To lastrow, 1 To 38)
indi = 2
For rowcnt = 2 To 30
    For i = 2 To lastrow
        If inarr(i, 38) = rowcnt Then ' check is AL = rowcnt your requirements are ambiguous I presume row count is in AL
            currentid = inarr(i, 1)
            copi = i
            First = True
            For j = i + 1 To lastrow
                ' look for duplicates
                If inarr(j, 1) = currentid And inarr(j, 1) <> "" Then
                   ' If First Then ' check if it is the first duplicate
                    ' check sequnce number AB
                        If inarr(j, 28) > inarr(copi, 28) Then
                            inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                            copi = j
                        Else
                        ' check if sequnce number equal
                            If inarr(j, 28) = inarr(copi, 28) Then
                            ' check dates
                                If inarr(j, 11) > inarr(copi, 11) Then
                                inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                                copi = j
                                End If
                            Else
                            inarr(copi, 1) = ""
                            End If
                        End If
                   ' End If
                End If
            Next j
            ' copy row
            If inarr(copi, 1) <> "" Then
                For k = 1 To 38
                outarr(indi, k) = inarr(copi, k)
                Next k
                inarr(copi, 1) = ""
                indi = indi + 1
            End If
        End If
    
    Next i
Next rowcnt
With Worksheets("Sheet2")
Range(.Cells(1, 1), .Cells(indi, 38)) = outarr
End With

End Sub
 
Upvote 0
Hey thanks for it, Its working fine now it is picking up only one ID ,and correct logic was being applied while its picking up the ID. But for Row count 3 their is a bug , it is picking only one ID but the conditions is not correct . the sequence is hiring but it picked up the latest date one .

For reference :
39692020-03-17
0​
3​
39692020-03-17
10​
3​
39692020-03-19
0​
3​

in the above example it has to pick the second row as is has highest seq number . but the macro picked this row

39692020-03-19
0​
3​

i think order of picking ID has to corrected , except that everything is AWSM...
 
Upvote 0
Try this, a subtle change!!!
VBA Code: 
Sub test()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 38)) ' pick A1 to Al lastrow
ReDim outarr(1 To lastrow, 1 To 38)
indi = 2
For rowcnt = 2 To 30
    For i = 2 To lastrow
        If inarr(i, 38) = rowcnt Then ' check is AL = rowcnt your requirements are ambiguous I presume row count is in AL
            currentid = inarr(i, 1)
            copi = i
            First = True
            For j = i + 1 To lastrow
                ' look for duplicates
                If inarr(j, 1) = currentid And inarr(j, 1) <> "" Then
                   ' If First Then ' check if it is the first duplicate
                    ' check sequnce number AB
                        If inarr(j, 28) > inarr(copi, 28) Then
                            inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                            copi = j
                        Else
                        ' check if sequnce number equal
                            If inarr(j, 28) = inarr(copi, 28) Then
                            ' check dates
                                If inarr(j, 11) > inarr(copi, 11) Then
                                inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                                copi = j
                                End If
                            End If
                            inarr(j, 1) = ""
                            
                        End If
                   ' End If
                End If
            Next j
            ' copy row
            If inarr(copi, 1) <> "" Then
                For k = 1 To 38
                outarr(indi, k) = inarr(copi, k)
                Next k
                inarr(copi, 1) = ""
                indi = indi + 1
            End If
        End If
    
    Next i
Next rowcnt
With Worksheets("Sheet2")
Range(.Cells(1, 1), .Cells(indi, 38)) = outarr
End With

End Sub
 
Upvote 0
The code you gave is perfect now . but again i had this challenge , it didn't work for the first ID ]. it worked from second ID .
For reference:

72732020-03-20
0​
2​
72732020-03-23
0​
2​
48882020-03-16
0​
2​
48882020-03-16
1​
2​
60802020-03-10
0​
2​
60802020-03-10
10​
2​
39692020-03-17
0​
3​
39692020-03-17
10​
3​
39692020-03-19
0​
3​


Output :
4888
3/16/2020​
1​
2​
6080
3/10/2020​
10​
2​
3969
3/17/2020​
10​
3​


it didnt take any action for 7273 . except that its great . can you please run some testing with the above data after making the change.
 
Upvote 0
Sorry, I ended up deleting an Else by mistake, trythis:

VBA Code: 
Sub test()
Dim outarr()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 38)) ' pick A1 to Al lastrow
ReDim outarr(1 To lastrow, 1 To 38)
indi = 2
For rowcnt = 2 To 30
    For i = 2 To lastrow
        If inarr(i, 38) = rowcnt Then ' check is AL = rowcnt your requirements are ambiguous I presume row count is in AL
            currentid = inarr(i, 1)
            copi = i
            First = True
            For j = i + 1 To lastrow
                ' look for duplicates
                If inarr(j, 1) = currentid And inarr(j, 1) <> "" Then
                   ' If First Then ' check if it is the first duplicate
                    ' check sequnce number AB
                        If inarr(j, 28) > inarr(copi, 28) Then
                            inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                            copi = j
                        Else
                        ' check if sequnce number equal
                            If inarr(j, 28) = inarr(copi, 28) Then
                            ' check dates
                                If inarr(j, 11) > inarr(copi, 11) Then
                                inarr(copi, 1) = "" ' clear previous duplicate to avoid copying agian
                                copi = j
                                End If
                             Else
                                inarr(j, 1) = ""
                            End If
                        End If
                   ' End If
                End If
            Next j
            ' copy row
            If inarr(copi, 1) <> "" Then
                For k = 1 To 38
                outarr(indi, k) = inarr(copi, k)
                Next k
                inarr(copi, 1) = ""
                indi = indi + 1
            End If
        End If
    
    Next i
Next rowcnt
With Worksheets("Sheet2")
Range(.Cells(1, 1), .Cells(indi, 38)) = outarr
End With

End Sub
 
Upvote 0
Thank you so much .. You're soo kind . Really appreciate your work .
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Question Question
Excel VBA - Check For Duplicates and Return the Count on a Large Data Set
Replies
4
Views
262
Kaper
Kaper
C
  • Solved
VBA macro: insert row if condition is met and apply formulae
Replies
3
Views
289
CXsjr
C
K
  • Solved
Code to search job id from multiple sources and update main spreadsheet.
2
Replies
10
Views
594
mumps
mumps
A
  • Question Question
Excel data from one sheet, copy cells from row i'm working on to excel 'form' based on cell value
Replies
2
Views
510
asiuol84
A
I
  • Question Question
Move multiple rows from one table to another using conditional trigger
Replies
2
Views
863
ItsNursinTime
I

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top