Search for two values and copy everything in between in a loop and paste to separate rows on different sheet

[mrjackg]

Hello I am trying to find two key words in a data dump of text that has the words reoccurring. I am wanting to copy and past all the text on the rows between these key words and paste the results to a new row on a sheet named "result".

The below code does the most part of what I am trying to do but it overwrites each iteration of the loop over the top of the previous found result on the new sheet. I just need the code to add each iteration on a new line of the sheet named "Result"

I am new to VBA and not sure what would do it. Any help is very much appreciated!

Sub Test()
   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("Sheet1").Range("a1:a" & lastrow)


   For rownum = 1 To lastrow
    Do
       If .Cells(rownum, 1).Value = "WordA" Then
          startrow = rownum
       End If

       rownum = rownum + 1


   If (rownum > lastrow) Then Exit For

   Loop Until .Cells(rownum, 1).Value = "WordB"
   endrow = rownum
   rownum = rownum + 1

   Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy


   Sheets("Result").Select
   Range("A1").Select
   ActiveSheet.Paste


   Next rownum
   End With
   End Sub

 

[footoo]

Maybe :

Sub Test()
With Sheets("Sheet1")
    .Range(.[A:A].Find("WordA")(2), .[A:A].Find("WordB")(0)).EntireRow.Copy Sheets("Result").[A1]
End With
End Sub

Assumes WordA will always appear before WordB

 

[mrjackg]

Maybe :

Sub Test()
With Sheets("Sheet1")
    .Range(.[A:A].Find("WordA")(2), .[A:A].Find("WordB")(0)).EntireRow.Copy Sheets("Result").[A1]
End With
End Sub

Assumes WordA will always appear before WordB

Yes that is correct. I am also trying concatenate the resulting rows that are selected into one cell in the results sheet on the next blank row.

 

[footoo]

If you mean that you want to concatenate the cells between WordA and WordB then paste the result to a single cell on the Result sheet :

Sub Test()
Dim rng As Range, cel As Range, conc$
With Sheets("Sheet1")
    Set rng = .Range(.[A:A].Find("WordA")(2), .[A:A].Find("WordB")(0))
End With
For Each cel In rng
    conc = conc & cel & " "
Next
Sheets("Result").Cells(Rows.Count, "A").End(3)(2) = conc
End Sub

If not, post some sample data showing what you want to do.