Copy if VBA

[pietras152]

Hi!

I am currently working on a quite big VBA aplication. One of the elements, however, made me crazy and I can't write a proper code.
Here is the problem:



I need to copy cells from 5 columns on the right when cells from first 5 columns are the same.
I know the problem might be easy but I have problem with inserting another clear rows below which depends on the amount of simillar rows above.
The colours are only to make this table easy to read and to depict the problem.

Here is the link to the data from image above.

Download 1.xlsx from Sendspace.com - send big files the easy way

Thank you for your attention. I really would appreciate any help!

 

[patel45]

Sub a()
LR = Cells(Rows.Count, "A").End(xlUp).Row
For r = LR To 2 Step -1
    Rows(r + 1).Insert
    Range("F" & r & ":J" & r).Cut Range("A" & r + 1 & ":E" & r + 1)
Next
LR = Cells(Rows.Count, "A").End(xlUp).Row
For r = LR - 1 To 4 Step -1
  If Range("A" & r) = Range("A" & r - 2) And Range("B" & r) = Range("B" & r - 2) _
  And Range("C" & r) = Range("C" & r - 2) And Range("D" & r) = Range("D" & r - 2) _
  And Range("E" & r) = Range("E" & r - 2) Then
    Rows(r).Delete
  End If
Next
End Sub

 

[pietras152]

Thank you very much! The code works great!

 

[pietras152]

Sub a()
LR = Cells(Rows.Count, "A").End(xlUp).Row
For r = LR To 2 Step -1
    Rows(r + 1).Insert
    Range("F" & r & ":J" & r).Cut Range("A" & r + 1 & ":E" & r + 1)
Next
LR = Cells(Rows.Count, "A").End(xlUp).Row
For r = LR - 1 To 4 Step -1
  If Range("A" & r) = Range("A" & r - 2) And Range("B" & r) = Range("B" & r - 2) _
  And Range("C" & r) = Range("C" & r - 2) And Range("D" & r) = Range("D" & r - 2) _
  And Range("E" & r) = Range("E" & r - 2) Then
    Rows(r).Delete
  End If
Next
End Sub

I'm sorry but I have noticed considerable problem with this code.
Please look at this example:
Download example.xlsx from Sendspace.com - send big files the easy way


-- removed inline image ---


It occurs that when 5 cells from the columns on the right are the same for other rows they are deleted because they are treated as duplicates.

Thank you very much for help and I would be very grateful if you help me with this.

 

[patel45]

Sub a()
LR = Cells(Rows.Count, "A").End(xlUp).Row
For r = LR To 2 Step -1
    Rows(r + 1).Insert
    Range("F" & r & ":J" & r).Cut Range("A" & r + 1 & ":E" & r + 1)
Next
LR = Cells(Rows.Count, "A").End(xlUp).Row
For r = LR - 1 To 4 Step -1
  If Range("A" & r) = Range("A" & r - 2) And Range("B" & r) = Range("B" & r - 2) _
  And Range("C" & r) = Range("C" & r - 2) And Range("D" & r) = Range("D" & r - 2) _
  And Range("E" & r) = Range("E" & r - 2) [COLOR=#ff0000]And Range("A" & r) = "P" Then Rows(r).Delete[/COLOR]
Next
End Sub

 

[pietras152]

Thank you! Now it's all working thanks to your help.