Create new sheets from data?

[TheWennerWoman]

Book1.xlsm
	A	B	C	D	E
1	code1	code2	vx	source	flag
2	C5678	103000	100	ZV0001
3	X00001	145444	28	ZV0001
4	X00001	173000	20	ZV0001
5	X00001	199000	19	ZV0001
6	X00001	212000	20	ZV0001
7	X00001	255666	13	ZV0001
8	C5678	103000	90	ZV0002
9	X00002	145444	17	ZV0002
10	X00002	173000	19	ZV0002
11	X00002	199000	27	ZV0002
12	X00002	212000	16	ZV0002
13	X00002	255666	11	ZV0002	end
14	C5678	103000	80	ZV0003
15	X00003	145444	15	ZV0003
16	X00003	173000	10	ZV0003
17	X00003	199000	32	ZV0003
18	X00003	212000	14	ZV0003
19	X00003	255666	9	ZV0003
20	C5678	103000	70	ZV0004
21	X00004	145444	13	ZV0004
22	X00004	173000	27	ZV0004
23	X00004	199000	10	ZV0004
24	X00004	212000	12	ZV0004
25	X00004	255666	8	ZV0004	end
26	C5678	103000	60	ZV0005
27	X00005	145444	11	ZV0005
28	X00005	173000	21	ZV0005
29	X00005	199000	10	ZV0005
30	X00005	212000	10	ZV0005
31	X00005	255666	8	ZV0005
Sheet2

This is just a small sample to illustrate what I am trying to achieve.

I have thousands of rows of data on one sheet. I need to split this data out based on whether the word "end" appears in column E. So in the above, A2:A13 would be copied to a new worksheet.

Then A14:A25 would be copied to a new sheet.

And so on. So the flow would be (i) identify first range to be copied, (ii) add a new worksheet, (iii) paste the data.

Any pointers appreciated.

 

[Peter_SSs]

I have assumed that the last row of your actual data will also have an "end" in column E.
If that is not the case then please advise what should happen to the last block of data that has no "end"

Try this with a copy of your workbook.

Sub New_Sheets()
  Dim fr As Long, i As Long
  Dim rend As Range
  
  Application.ScreenUpdating = False
  With Sheets("Sheet2")
    fr = 2
    Set rend = .Columns("E").Find(What:="end")
    Do
      i = i + 1
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New " & i
      .Rows(fr & ":" & rend.Row).Copy Destination:=Sheets(Sheets.Count).Range("A1")
      fr = rend.Row + 1
      Set rend = .Columns("E").Find(What:="end", After:=rend)
    Loop Until rend.Row < fr
  End With
  Application.ScreenUpdating = True
End Sub

 

[TheWennerWoman]

I have assumed that the last row of your actual data will also have an "end" in column E.
If that is not the case then please advise what should happen to the last block of data that has no "end"

Try this with a copy of your workbook.

Sub New_Sheets()
  Dim fr As Long, i As Long
  Dim rend As Range
 
  Application.ScreenUpdating = False
  With Sheets("Sheet2")
    fr = 2
    Set rend = .Columns("E").Find(What:="end")
    Do
      i = i + 1
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New " & i
      .Rows(fr & ":" & rend.Row).Copy Destination:=Sheets(Sheets.Count).Range("A1")
      fr = rend.Row + 1
      Set rend = .Columns("E").Find(What:="end", After:=rend)
    Loop Until rend.Row < fr
  End With
  Application.ScreenUpdating = True
End Sub

That works perfectly.

Assume that the last row of data has no "end", what amendments to this code are needed to capture the last block of data (from the last "end" to the last row)?

 

[Tom.Jones]

Peter_SSs​

I have assumed that the last row of your actual data will also have an "end" in column E.
If that is not the case then please advise what should happen to the last block of data that has no "end"

 

[Peter_SSs]

@Tom.Jones
Was there supposed to be a suggestion or question included in your post?

Assume that the last row of data has no "end", what amendments to this code are needed to capture the last block of data (from the last "end" to the last row)?

This should work whether or not the last row has an "end"

Sub New_Sheets_v2()
  Dim fr As Long, i As Long, lrD As Long
  Dim rend As Range
 
  Application.ScreenUpdating = False
  lrD = Range("D" & Rows.Count).End(xlUp).Row
  With Sheets("Sheet2")
    fr = 2
    Set rend = .Columns("E").Find(What:="end")
    Do
      i = i + 1
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New " & i
      .Rows(fr & ":" & rend.Row).Copy Destination:=Sheets(Sheets.Count).Range("A1")
      If rend.Row = lrD Then Exit Do
      fr = rend.Row + 1
      Set rend = .Columns("E").Find(What:="end", After:=rend)
      If rend.Row < fr Then Set rend = Range("E" & lrD)
    Loop Until rend.Row < fr
  End With
  Application.ScreenUpdating = True
End Sub

 

[TheWennerWoman]

This should work whether or not the last row has an "end"

Sub New_Sheets_v2()
  Dim fr As Long, i As Long, lrD As Long
  Dim rend As Range
 
  Application.ScreenUpdating = False
  lrD = Range("D" & Rows.Count).End(xlUp).Row
  With Sheets("Sheet2")
    fr = 2
    Set rend = .Columns("E").Find(What:="end")
    Do
      i = i + 1
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New " & i
      .Rows(fr & ":" & rend.Row).Copy Destination:=Sheets(Sheets.Count).Range("A1")
      If rend.Row = lrD Then Exit Do
      fr = rend.Row + 1
      Set rend = .Columns("E").Find(What:="end", After:=rend)
      If rend.Row < fr Then Set rend = Range("E" & lrD)
    Loop Until rend.Row < fr
  End With
  Application.ScreenUpdating = True
End Sub

That's very impressive and works perfectly - thank you very much

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.