Copy datas between 2 keywords and looping until all are extracted

[ceclay]

I have this VBA code below which will copy the data between Top * Model and Opens: . My problem with the code below is it only will copy the first set (Top Asian Model) and will not proceed with the next set (Top Australian Model).

Sub Top_Model()
Application.ScreenUpdating = False
  Dim rStart As Range, rEnd As Range
  Dim r As Long
  Dim last As Long, t As Long
 

 
  Set wph = Sheets("Sheet1")
  Set wso = Sheets("Sheet2")
 
    Set rStart = wph.Columns("A").Find(What:="Top * Model", LookAt:=xlWhole, MatchCase:=False)
  If Not rStart Is Nothing Then
    Set rEnd = wph.Columns("A").Find(What:="Opens:", After:=rStart, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
    If Not rEnd Is Nothing Then
      r = rStart.Row
      Do While r + 2 < rEnd.Row
        wso.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = Application.Transpose(wph.Range("A" & r).Resize(3).Value)
        r = r + 3
      Loop
    End If
  End If
 
  wso.Activate
 Application.ScreenUpdating = True
End Sub

Below is the sample list of data and it is dynamic. sometimes there is Top European Model, Top African Model etc,

Test.xlsm
	A
3	Top Asian Model
4	Country
5	Height
6	Chiharu
7	China
8	6.2
9	Ming
10	Taiwan
11	6.1
12	Zhao Lei
13	Japan
14	6.25
15	Du Juan
16	China
17	6.3
18	Liu Wen
19	South Korea
20	5.9
21	Opens:
22	Greatest Comedian
23	Mr Bean
24	Josie Long
25	Michaela Coel
26	Mindy Kaling
27	Jordan Brookes
28	Matt Berry
29	Closes:
30	Top Australian Model
31	Country
32	Height
33	Bridget
34	Melbourne
35	5.9
36	Kelly
37	New South Wales
38	6.2
39	Bambi
40	Victoria
41	6.3
42	Opens:
Sheet1

Below is my desired outcome

Test.xlsm
	A	B	C
2	Top Asian Model	Country	Height
3	Chiharu	China	6.2
4	Ming	Taiwan	6.1
5	Zhao Lei	Japan	6.25
6	Du Juan	China	6.3
7	Liu Wen	South Korea	5.9
8	Top Australian Model	Country	Height
9	Bridget	Melbourne	5.9
10	Kelly	New South Wales	6.2
11	Bambi	Victoria	6.3
Sheet2

 

[Marc L]

According to your attachment a VBA demonstration for starters :​

Sub Demo1()
    Dim W, V(), L&, B As Boolean, R&
        W = Sheet1.UsedRange.Value2
        ReDim V(1 To UBound(W) \ 3, 1 To 3)
    For L = 1 To UBound(W)
            If W(L, 1) = "Opens:" Then B = False Else If W(L, 1) Like "Top *" Then B = True
        If B Then
            R = R + 1
            V(R, 1) = W(L, 1)
            V(R, 2) = W(L + 1, 1)
            L = L + 2
            V(R, 3) = W(L, 1)
        End If
    Next
    With Sheet2
        .[A1:C1].Resize(R).Value2 = V
         If .UsedRange.Rows.Count > R Then .UsedRange.Rows(R + 1 & ":" & .UsedRange.Rows.Count).Clear
        .UsedRange.Columns.AutoFit
    End With
End Sub

 

[ceclay]

Thank you very much @Marc L