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

Youngdand

Board Regular
Joined
Sep 29, 2017
Messages
120
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?


AB
CDEFGHIJKLMNOPQR
1Company 1123456987654AB64VBAName 1Add1Add2Add3Add4Add5PcodeSome infoMore info27/06/201716025/07/2017
2Company 1234567876543AB64VBAName 1Add1Add2Add3Add4Add5PcodeSome infoMore info26/06/201716024/07/2017
3Company 2345678765432AB64VBAName 1Add1Add2Add3Add4Add5PcodeSome infoMore info06/07/201713503/08/2017
4Company 2456789654321BC17CLJName 2Add1Add2Add3Add4Add5PcodeSome infoMore info05/07/201713502/08/2017
5Company 2567890543210
BC17CLJ
Name 2DiffAdd1
DiffAdd2DiffAdd3DiffAdd4DiffAdd5DiffPcodeSome infoMore info29/06/201713527/07/2017
6Company 3678901432109DE57ZTDName 3Add1Add2Add3Add4Add5PcodeSome infoMore info07/07/201713504/08/2017
7Company 3789012321098
DE57ZTD
Name 3Add1Add2Add3Add4Add5PcodeSome infoMore info13/06/201716011/07/2017
8
Company 3
890123
210987
DE57ZTD

<tbody>
</tbody>
Name 3
Add1Add2Add3Add4Add5PcodeSome infoMore info
03/08/201716031/08/2017
9Company 4901234
109876EF57ZBCName 4Add1Add2Add3Add4Add5PcodeSome infoMore info06/06/201716004/07/2017

<tbody>
</tbody>
Sheet1
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

cerfani

Well-known Member
Joined
Dec 15, 2014
Messages
1,136
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
 
Last edited:

Youngdand

Board Regular
Joined
Sep 29, 2017
Messages
120
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

Board Regular
Joined
Sep 29, 2017
Messages
120
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
 
Last edited:

cerfani

Well-known Member
Joined
Dec 15, 2014
Messages
1,136

ADVERTISEMENT

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.
 
Last edited:

cerfani

Well-known Member
Joined
Dec 15, 2014
Messages
1,136
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

Board Regular
Joined
Sep 29, 2017
Messages
120

ADVERTISEMENT

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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
46,530
Office Version
  1. 365
Platform
  1. Windows
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

Board Regular
Joined
Sep 29, 2017
Messages
120
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

Board Regular
Joined
Sep 29, 2017
Messages
120
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,334
Messages
5,528,091
Members
409,802
Latest member
joeino

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top