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

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

mrshl9898

Well-known Member
Joined
Feb 6, 2012
Messages
1,951
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,951
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
156
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
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,505
Messages
5,837,737
Members
430,514
Latest member
Stanislav546564

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