Copy 3 rows above and insert?

[hxrolan091]

Hi

I need help with this macro code. I just want to copy the content of 3 above with the number (91) and insert the copied rows below it and loop it.

and secondly. I have thousands of rows (17501). Is there other ways to speed up the copy and insert process?

Here is the marco code. I just can't seem to get the right.

Thanks in advance!!

Public Sub CopyRows()

Dim Col As Variant
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "D"
StartRow = 2
LastRow = Sheets("Sheet1").Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With Sheets("Sheet1")
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) = "91" Then
            'Cells(R + 1, Col).Offset(-3, 0).EntireRow.Copy
            '.Cells(R, Col).EntireRow.Insert Shift:=xlDown
            .Cells(R + 1, Col).EntireRow.Copy
            .Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
        End If
Next R
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
    
End Sub

Thanks in advance!!

 

[Joe4]

Welcome to the Board!

Will your current data always be in clocks of 3 like that (as far as column D is concerned)?
Can you show us an image of your expected output after the code runs?

 

[hxrolan091]

Thank you for your quick reply! I need the copied rows below to be exactly as above 3 rows (as in the pic).

 

[Joe4]

Try this code:

Sub MyCopy()

    Dim lastRow As Long
    Dim r As Long
    
    Application.ScreenUpdating = False
    
'   Find last row with data in column D
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    
'   Loop through rows backwards in blocks of 3
    For r = lastRow To 1 Step -3
'       Check value of column D
        If Cells(r, "D") = 91 Then
'           Insert three blank rows
            Rows(r + 1 & ":" & r + 3).Insert
'           Copy rows above down
            Range(Cells(r - 2, "A"), Cells(r, "E")).Copy Cells(r + 1, "A")
        End If
    Next r
   
    Application.ScreenUpdating = True
    
End Sub

 

[hxrolan091]

Try this code:

Sub MyCopy()

    Dim lastRow As Long
    Dim r As Long
   
    Application.ScreenUpdating = False
   
'   Find last row with data in column D
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
   
'   Loop through rows backwards in blocks of 3
    For r = lastRow To 1 Step -3
'       Check value of column D
        If Cells(r, "D") = 91 Then
'           Insert three blank rows
            Rows(r + 1 & ":" & r + 3).Insert
'           Copy rows above down
            Range(Cells(r - 2, "A"), Cells(r, "E")).Copy Cells(r + 1, "A")
        End If
    Next r
  
    Application.ScreenUpdating = True
   
End Sub

Interesting. It looks like the code creates an extra the number of times.

My other macro do the same as above:

    Dim Col As Variant
    Dim BlankRows As Long
    Dim lastRow As Long
    Dim r As Long
    Dim StartRow As Long

    Col = "D"
    StartRow = 1
    BlankRows = 1

    lastRow = Cells(Rows.Count, Col).End(xlUp).Row

    Application.ScreenUpdating = False

    With ActiveSheet
        For r = lastRow To StartRow + 3 Step -1
            If .Cells(r, Col) = "91" Then
                .Cells(r, Col).Resize(3).EntireRow.Copy
                .Cells(r, Col).EntireRow.Insert Shift:=xlUp
            End If
        Next r
    End With

Thanks for any help!

 

[Joe4]

Hmmm...

I tried to recreate the example you posted up in post number 3, and it worked just fine for me.

I suspect your real data isn't quite what you showed (as you only showed a portion of it).
I assumed that you always had blocks of 3 (I even asked you to confirm that, but you never responded to that question).

Can you upload the file that you are trying to run this on, so I can see what all the data really looks like?
You will need to upload it to a file sharing site and provide a link to it.

 

[hxrolan091]

It's work fine for the first part. Scroll down further that corresponds to the number 91 been replaced by number 33.

Here is the test file as requested.

 

[Joe4]

It's work fine for the first part. Scroll down further that corresponds to the number 91 been replaced by number 33.

That is because your actual data does not always reflect the pattern shown in the sample data your originally posted.
In the data you posted, all the data posted occurred in blocks of 3, when looking at the "Tag" field (3 records of "2", then 3 records of "33", 3 records of "91", 3 records of "11", etc). But in looking at your actual data file you just posted, you have some records of "11" that appear in blocks of 4.

I asked you a few times if this is always the case (if they always appeared in groups of 3), and you did not answer those questions. Remember, all that we have to go on is what you provide to us. So if you do not provide us with good, representative data and answer all the questions we ask, we are forced to make assumptions based on what you have posted. So the code that I posted does in fact answer the question you asked, and works on the data you originally presented, but not on all of your actual data because you left out some key details.

We might be able to come at this from a different angle, but need more information from you.
Will these blocks of 91 that you want to copy ALWAYS/ONLY appear in blocks of 3?
If they may appear in blocks of 4, like the 11s sometimes do, do you still only want to copy 3 records?
If so, which 3 of the 4 get copied, and which one doesn't?

 

[Joe4]

If 91 can only appear in blocks of 3, then this variation of the code I posted should work, regardless of how many times other blocks may appear.

Sub MyCopy()

    Dim lastRow As Long
    Dim r As Long
    
    Application.ScreenUpdating = False
    
'   Find last row with data in column D
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    
'   Loop through rows backwards in blocks of 3
    r = lastRow
    Do Until r <= 1
'       Check value of column D
        If Cells(r, "D") = 91 Then
'           Insert three blank rows
            Rows(r + 1 & ":" & r + 3).Insert
'           Copy rows above down
            Range(Cells(r - 2, "A"), Cells(r, "E")).Copy Cells(r + 1, "A")
'           Move up three rows
            r = r - 3
        Else
'           Move up one row
            r = r - 1
        End If
    Loop
   
    Application.ScreenUpdating = True
    
End Sub

 

[hxrolan091]

The mistake was mine. I got my patterns somehow mixed up. It's supposed to be like "3 records of (2), 3 records of (33), 3 records of (91) and 3 records of (11)". I wonder why I didn't see it there before

The code at #4 works perfectly fine. Thank you for your time and effort in helping me, it save me an incredible amount of hours to copy and paste.