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

[Aldo88]

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

 

[mrshl9898]

Assuming your data starts in A1, try this:

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

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]

I tried that but is only copying the last set

 

[mrshl9898]

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]

Hi @Aldo88

What did you specify as your destination at this point?

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

If it was something like:

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

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