Copy set of rows if first 2 rows meet criteria until row changes value

Aldo88

New Member
Joined
Jul 12, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi i'm new to macros and i need to create one where it copy range of rows if the first two rows meet criteria until the last row changes value.

For example
Copy rows if :
1st row = "h"
2nd row = "L"
3rd row= "D"

Copy rows until 3rd row changes back to "H"

H
L
D
D
D
D

Do not copy if after row "h" and "l" is not followed by an "D" row

H
L
H
L
H
L
 

Attachments

  • 1594531420595.png
    1594531420595.png
    4 KB · Views: 4

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

mrshl9898

Well-known Member
Joined
Feb 6, 2012
Messages
1,791
Assuming your data starts in A1, try this:

*You just need to specify where the copied data is going (if anywhere)

VBA Code:
Sub copy()

Dim sht As Worksheet
Dim rownum As Long
Dim lastDrow As Long
Dim lastrow As Long

Set sht = ActiveSheet
rownum = 1
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

Do Until rownum = lastrow + 1
If Cells(rownum, 1) = "H" And Cells(rownum + 1, 1) = "L" And Cells(rownum + 2, 1) = "D" Then
lastDrow = rownum + 2
    Do Until Cells(lastDrow + 1, 1) <> "D"
    lastDrow = lastDrow + 1
    Loop
Range(Cells(rownum, 1), Cells(lastDrow, 1)).copy '''SELECT WHERE TO COPY TO HERE
rownum = lastDrow
End If
rownum = rownum + 1
Loop

End Sub
 

Aldo88

New Member
Joined
Jul 12, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
I tried that but is only copying the last set
 

mrshl9898

Well-known Member
Joined
Feb 6, 2012
Messages
1,791
Try stepping through the code with F8. It is working, you're just seeing the end.

As mentioned this only copies data, you need to decide what to do with it after that happens as you haven't said anything about that part.
 

PureBluff

Board Regular
Joined
Apr 4, 2014
Messages
155
Hi @Aldo88

What did you specify as your destination at this point?

VBA Code:
Range(Cells(rownum, 1), Cells(lastDrow, 1)).copy '''SELECT WHERE TO COPY TO HERE

If it was something like:

VBA Code:
Range(Cells(rownum, 1), Cells(lastDrow, 1)).copy Destination:=Worksheets("Output").Range("b2")

Then, as youre in a loop, it'll reuse the destination on the next Header/Line/Detail trigger

Where do you want to put your data / what are you wanting to do with it once it's split out?

This would put the data on sheets "Output" fro row 2, with a spacer between each output

VBA Code:
Sub copy()

Dim sht As Worksheet
Dim rownum As Long
Dim lastDrow As Long
Dim lastrow As Long


Dim i As Long 'add this
Dim DstSht As Worksheet 'add this
Set DstSht = ThisWorkbook.Sheets("output") 'add this

i = 2 ' set this as your starting output row assuming you want it all on one sheet

Set sht = ActiveSheet
rownum = 1
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

Do Until rownum = lastrow + 1
If Cells(rownum, 1) = "H" And Cells(rownum + 1, 1) = "L" And Cells(rownum + 2, 1) = "D" Then
lastDrow = rownum + 2
    Do Until Cells(lastDrow + 1, 1) <> "D"
    lastDrow = lastDrow + 1
    Loop
Range(Cells(rownum, 1), Cells(lastDrow, 1)).copy Destination:=DstSht.Range("b" & i) ' variable output destination row of i
rownum = lastDrow
End If
rownum = rownum + 1
i = DstSht.Cells(DstSht.Rows.Count, "B").End(xlUp).Row + 2 ' increment destination row by 2 rows at each Order Header change to give a blank row
Loop

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,130,047
Messages
5,639,766
Members
417,109
Latest member
996

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top