copy selection and paste to end of row if 4 criteria are met

Youngdand · Feb 28, 2018

Hi,

I am struggling with the below problem.

I have a set of data which is 18 columns long and could have many rows.

the data may have many similar items.

For each item where columns a,d,g,h,i,j,k,l,m match another row within the sheet, i need to cut the range a to r to the end of the row containing the first instance, and subsequent matches should be pasted again to the end of this row and so on. below is a small example of the data.

for example row 2 should be pasted to the end of row 1. row 7 should be added to the end of row 6, and row 8 should be added at the end of this.

Can anyone help with this?

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

Company 1

AB64VBA

Name 1

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

Company 1

AB64VBA

Name 1

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

Company 2

AB64VBA

Name 1

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

Company 2

BC17CLJ

Name 2

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

Company 2

BC17CLJ

Name 2

DiffAdd1

DiffAdd2

DiffAdd3

DiffAdd4

DiffAdd5

DiffPcode

Some info

More info

Company 3

DE57ZTD

Name 3

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

Company 3

DE57ZTD

Name 3

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

Company 3

DE57ZTD

Name 3

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

Company 4

EF57ZBC

Name 4

Add1

Add2

Add3

Add4

Add5

Pcode

Some info

More info

<tbody>
[TD="align: center"]1[/TD]

[TD="align: right"]123456[/TD]
[TD="align: right"]987654[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]27/06/2017[/TD]
[TD="align: right"]160[/TD]
[TD="align: right"]25/07/2017[/TD]

[TD="align: center"]2[/TD]

[TD="align: right"]234567[/TD]
[TD="align: right"]876543[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]26/06/2017[/TD]
[TD="align: right"]160[/TD]
[TD="align: right"]24/07/2017[/TD]

[TD="align: center"]3[/TD]

[TD="align: right"]345678[/TD]
[TD="align: right"]765432[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]06/07/2017[/TD]
[TD="align: right"]135[/TD]
[TD="align: right"]03/08/2017[/TD]

[TD="align: center"]4[/TD]

[TD="align: right"]456789[/TD]
[TD="align: right"]654321[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]05/07/2017[/TD]
[TD="align: right"]135[/TD]
[TD="align: right"]02/08/2017[/TD]

[TD="align: center"]5[/TD]

[TD="align: right"]567890[/TD]
[TD="align: right"]543210
[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]29/06/2017[/TD]
[TD="align: right"]135[/TD]
[TD="align: right"]27/07/2017[/TD]

[TD="align: center"]6[/TD]

[TD="align: right"]678901[/TD]
[TD="align: right"]432109[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]07/07/2017[/TD]
[TD="align: right"]135[/TD]
[TD="align: right"]04/08/2017[/TD]

[TD="align: center"]7[/TD]

[TD="align: right"]789012[/TD]
[TD="align: right"]321098
[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]13/06/2017[/TD]
[TD="align: right"]160[/TD]
[TD="align: right"]11/07/2017[/TD]

[TD="align: center"]8
[/TD]

[TD="align: right"]890123
[/TD]
[TD="align: right"]210987[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]03/08/2017[/TD]
[TD="align: right"]160[/TD]
[TD="align: right"]31/08/2017[/TD]

[TD="align: center"]9[/TD]

[TD="align: right"]901234
[/TD]
[TD="align: right"]109876[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: right"]06/06/2017[/TD]
[TD="align: right"]160[/TD]
[TD="align: right"]04/07/2017[/TD]

</tbody>

Sheet1

cerfani · Feb 28, 2018

here is a rough draft (may have errors, untested) of some code to get you started, this only checks column A for duplicate values then cuts that row and places at the end of the first instance...

Code:

Sub CutCopies()
    Dim lastRow As Long, r As Long, r2 As Long

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row [COLOR=#008000]'get last row of table[/COLOR][COLOR=#00ff00]
[/COLOR]
    For r = 2 To lastRow[COLOR=#008000] 'check every row, use r to reference row that will be compared to dupes[/COLOR]
        If Not IsEmpty(Cells(r, 1)) Then [COLOR=#008000]'make sure current row wasn't cut[/COLOR]
            For r2 = r + 1 To lastRow [COLOR=#008000]'if the row has values then start looking for dupes, none will be above the row 'r'[/COLOR]
                If Not IsEmpty(Cells(r2, 1)) Then [COLOR=#008000]'make sure row comparing to wasn't already cut[/COLOR]
                    If Cells(r, 1) = Cells(r2, 1) Then [COLOR=#008000]'found copy[/COLOR]
                        Range(Cells(r2, 1), Cells(r2, 18)).Cut Cells(r, Cells(r, Columns.Count).End(xlToLeft).Column + 1) [COLOR=#008000]'Cut to the end of first instance which is reference by r[/COLOR]
                    End IF
                End If
            Next r2
        End If
    Next r

    [COLOR=#008000]'insert code to delete blank rows here[/COLOR]
End Sub

Youngdand · Mar 1, 2018

HI,

Thanks for your time in this. However for some reason when debugging it skips from the for to the end sub, i have amended the code slight to add in the additional ifs as per below. i have also changed lastrow to lr, as i am using this elsewhere in my code.

Code:

For r = 2 To lr 'check every row, use r to reference row that will be compared to dupes
        If Not IsEmpty(Cells(r, 1)) Then 'make sure current row wasn't cut
            For r2 = r + 1 To lr 'if the row has values then start looking for dupes, none will be above the row 'r'
                If Not IsEmpty(Cells(r2, 1)) Then 'make sure row comparing to wasn't already cut
                     If Cells(r, 1) And Cells(r, 4) And Cells(r, 7) And Cells(r, 8) And  Cells(r, 9) And Cells(r, 10) And Cells(r, 11) And Cells(r, 12) And  Cells(r, 13) = Cells(r2, 1) And Cells(r2, 4) And Cells(r2, 7) And  Cells(r2, 8) And Cells(r2, 9) And Cells(r2, 10) And Cells(r2, 11) And  Cells(r2, 12) And Cells(r2, 13) Then 'found copy
                         Range(Cells(r2, 1), Cells(r2, 18)).Cut Cells(r, Cells(r,  Columns.Count).End(xlToLeft).Column + 1) 'Cut to the end of first  instance which is reference by r
                    End If
                End If
            Next r2
        End If
    Next r

Some of the columns that i am testing against may be blank, would this cause an issue??

Thanks,

Dan.

Youngdand · Mar 1, 2018

Youngdand said:

HI,

Thanks for your time in this. However for some reason when debugging it skips from the for to the end sub, i have amended the code slight to add in the additional ifs as per below. i have also changed lastrow to lr, as i am using this elsewhere in my code.

Code:

For r = 2 To lr 'check every row, use r to reference row that will be compared to dupes
        If Not IsEmpty(Cells(r, 1)) Then 'make sure current row wasn't cut
            For r2 = r + 1 To lr 'if the row has values then start looking for dupes, none will be above the row 'r'
                If Not IsEmpty(Cells(r2, 1)) Then 'make sure row comparing to wasn't already cut
                     If Cells(r, 1) And Cells(r, 4) And Cells(r, 7) And Cells(r, 8) And  Cells(r, 9) And Cells(r, 10) And Cells(r, 11) And Cells(r, 12) And  Cells(r, 13) = Cells(r2, 1) And Cells(r2, 4) And Cells(r2, 7) And  Cells(r2, 8) And Cells(r2, 9) And Cells(r2, 10) And Cells(r2, 11) And  Cells(r2, 12) And Cells(r2, 13) Then 'found copy
                         Range(Cells(r2, 1), Cells(r2, 18)).Cut Cells(r, Cells(r,  Columns.Count).End(xlToLeft).Column + 1) 'Cut to the end of first  instance which is reference by r
                    End If
                End If
            Next r2
        End If
    Next r

Some of the columns that i am testing against may be blank, would this cause an issue??

Thanks,

Dan.

Sorry me being a wally.

The following works fine however, its too inefficient for my use. My Sheet may contain a few thousand lines, so in essence, this code will progressively run through every line and check against the remaining lines in the sheet for duplicates, so will end up cycling through many 100's of thousands / millions of lines.

Is there a better way?

Code:

Sub Format_SRL()

Dim lr As Long, r As Long, r2 As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
    Selection.Cut
    Columns("A:A").Select
    Selection.Cut
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.Cut
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Selection.Cut
     Columns("W:W").Select
    Selection.Insert Shift:=xlToRight
    Columns("H:H").Select
    Selection.Cut
    Columns("Q:Q").Select
    Selection.Insert Shift:=xlToRight
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Columns("H:H").Select
    Selection.Cut
    Columns("A:A").Select
    ActiveSheet.Paste
    Columns("H:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("L:L").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("N:N").Select
    Selection.Cut
    Columns("S:S").Select
    Selection.Insert Shift:=xlToRight
    Columns("O:P").Select
    Selection.Delete Shift:=xlToLeft
    Columns("R:R").Select
    Selection.Delete Shift:=xlToLeft
    Range("R2").Select
    ActiveCell.FormulaR1C1 = "=RC[-2]+28"
    Range("R2").Select
    Selection.AutoFill Destination:=Range("R2:R" & lr)
    Rows("1:1").Select
    Range("O1").Activate
    Selection.Delete Shift:=xlUp
    Range("a1").Select
    Application.CutCopyMode = False

For r = 1 To lr 'check every row, use r to reference row that will be compared to dupes
        If Not IsEmpty(Cells(r, 1)) Then 'make sure current row wasn't cut
            For r2 = r + 1 To lr 'if the row has values then start looking for dupes, none will be above the row 'r'
                If Not IsEmpty(Cells(r2, 1)) Then 'make sure row comparing to wasn't already cut
                    If Cells(r, 1) = Cells(r2, 1) And Cells(r, 4) = Cells(r2, 4) And Cells(r, 7) = Cells(r2, 7) And Cells(r, 8) = Cells(r2, 8) And Cells(r, 9) = Cells(r2, 9) And Cells(r, 10) = Cells(r2, 10) And Cells(r, 11) = Cells(r2, 11) And Cells(r, 12) = Cells(r2, 12) And Cells(r, 13) = Cells(r2, 13) Then 'found copy
                        Range(Cells(r2, 1), Cells(r2, 18)).Cut Cells(r, Cells(r, Columns.Count).End(xlToLeft).Column + 1) 'Cut to the end of first instance which is reference by r
                    End If
                End If
            Next r2
        End If
    Next r
    
Application.ScreenUpdating = True
    
End Sub

cerfani · Mar 1, 2018

Late reply... yeah I believe the nature of the task requires a loop of the following rows for each row. Maybe another way, you could write a macro that pivots the data based on the columns you are comparing and you could get a count of each unique row based on those columns you are looking for matches. Then for each unique entry in the pivot you could filter the data and then cut every visible order to the first one. That would be less loops.

Also not sure if it increases performance but you could get rid of one of the empty checks...

Code:

If Not IsEmpty(Cells(r2, 1))

since after this line you are checking equality against a non blank value so it will reduce the number of operations.

cerfani · Mar 1, 2018

Some of the columns that i am testing against may be blank, would this cause an issue??

Before each row is compared to its following rows for duplicates, the macro makes sure the row wasn't cut. So just make sure you check a column that should have a value...

Code:

If Not IsEmpty(Cells(r, 1)) Then 'make sure current row wasn't cut

The macro is currently making sure there is a value in column A before it starts checking every following row. If A might have blanks then use another column.

Youngdand · Mar 1, 2018

Cheers,

A in this instance will always have a value, so im ok with this. Its only really my address lines which may not have a value, as addresses vary , some may not have districts, of address line 2 for instance.

Actually, my concern over blanks, was me, being a wally, and my if statement was completely wrong, which is why it was skipping the loop completely as it could never find a match!

I was wondering, if this could be performed, by a using autofilter within a loop, as this would restrict it to only 1 loop through the data. but im not sure how i would go about it.

Cheers,

Dan.

Fluff · Mar 1, 2018

How about

Code:

Sub CopyMatchToRows()

   Dim cl As Range
   Dim v1 As String
   
   With CreateObject("scripting.dictionary")
      For Each cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         v1 = cl.Value & cl.Offset(, 3).Value & Join(Application.Transpose(Application.Transpose(cl.Offset(, 6).Resize(, 7))))
         If Not .exists(v1) Then
            .Add v1, cl
         Else
            cl.Resize(, 18).Cut Cells(.Item(v1).Row, Columns.Count).End(xlToLeft).Offset(, 1)
         End If
      Next cl
   End With
   Range("A:A").SpecialCells(xlBlanks).EntireRow.Delete
End Sub

This assumes that col R will always have a date

Youngdand · Mar 2, 2018

Fluff said:

How about

Code:

Sub CopyMatchToRows()

   Dim cl As Range
   Dim v1 As String
   
   With CreateObject("scripting.dictionary")
      For Each cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         v1 = cl.Value & cl.Offset(, 3).Value & Join(Application.Transpose(Application.Transpose(cl.Offset(, 6).Resize(, 7))))
         If Not .exists(v1) Then
            .Add v1, cl
         Else
            cl.Resize(, 18).Cut Cells(.Item(v1).Row, Columns.Count).End(xlToLeft).Offset(, 1)
         End If
      Next cl
   End With
   Range("A:A").SpecialCells(xlBlanks).EntireRow.Delete
End Sub

This assumes that col R will always have a date

HI Fluff,

Thanks for the above,

does this only work for duplicate in column a? as i need to expand the criteria so that it only copies rows where the following columns match A, D, G,H,I,J,K,L,M.

Thanks,

Dan.

Youngdand · Mar 2, 2018

HI Fluff,

Sorry, i re read though your code, and now understand hat you are doing, and it should work. However, i don't think its going to save much in time. I am currently 20 mins in and it hasn't finished yet and this is on 1700 rows. My machine is no slouch either, with 6 core processor and 24gb ram.

May have to admit defeat on this one, and have a stored procedure written in sql to handle it straight out of the DB.

Thanks for all your help though.

Cheers,

Dan.

copy selection and paste to end of row if 4 criteria are met

Youngdand

Board Regular

Excel Facts

cerfani

Well-known Member

Youngdand

Board Regular

Youngdand

Board Regular

cerfani

Well-known Member

cerfani

Well-known Member

Youngdand

Board Regular

Fluff

MrExcel MVP, Moderator

Youngdand

Board Regular

Youngdand

Board Regular

Similar threads

Forum statistics

Share this page

copy selection and paste to end of row if 4 criteria are met

Board Regular

Excel Facts

Well-known Member

Board Regular

Board Regular

Well-known Member

Well-known Member

Board Regular

MrExcel MVP, Moderator

Board Regular

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock