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

[Youngdand]

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
1	Company 1	123456	987654	AB64VBA			Name 1	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	27/06/2017	160	25/07/2017
2	Company 1	234567	876543	AB64VBA			Name 1	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	26/06/2017	160	24/07/2017
3	Company 2	345678	765432	AB64VBA			Name 1	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	06/07/2017	135	03/08/2017
4	Company 2	456789	654321	BC17CLJ			Name 2	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	05/07/2017	135	02/08/2017
5	Company 2	567890	543210	BC17CLJ			Name 2	DiffAdd1	DiffAdd2	DiffAdd3	DiffAdd4	DiffAdd5	DiffPcode	Some info	More info	29/06/2017	135	27/07/2017
6	Company 3	678901	432109	DE57ZTD			Name 3	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	07/07/2017	135	04/08/2017
7	Company 3	789012	321098	DE57ZTD			Name 3	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	13/06/2017	160	11/07/2017
8	Company 3	890123	210987	DE57ZTD <tbody> </tbody>			Name 3	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	03/08/2017	160	31/08/2017
9	Company 4	901234	109876	EF57ZBC			Name 4	Add1	Add2	Add3	Add4	Add5	Pcode	Some info	More info	06/06/2017	160	04/07/2017

<tbody>
</tbody>

Sheet1
​

 

[cerfani]

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...

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]

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.

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]

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.

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?

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]

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...

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]

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...

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]

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]

How about

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]

How about

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]

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.