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

#### Youngdand

##### Board Regular
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
5Company 2567890543210
BC17CLJ
7Company 3789012321098
DE57ZTD
8
Company 3
890123
210987
 DE57ZTD

<tbody>
</tbody>
Name 3
03/08/201716031/08/2017
9Company 4901234

<tbody>
</tbody>
Sheet1

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

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

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

Replies
2
Views
143
Replies
8
Views
501
Replies
1
Views
159
Replies
2
Views
164
Replies
2
Views
290

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