Second solution, Solution 2 for this thread
https://excelfox.com/forum/showthrea...cell-in-sheet2




Code:
Sub ConsolidateLines_Solution2() '   https://excelfox.com/forum/showthread.php/2815-Copy-data-from-multiple-rows-between-two-keyword-and-paste-the-data-in-row(s)-of-single-cell-in-sheet2
Rem 0 worksheets data info
Dim Ws1 As Worksheet, Ws2 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1): Set Ws2 = ThisWorkbook.Worksheets.Item(2)
Dim Lr As Long: Let Lr = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
 
Rem 3 Initial to get started, finding first start point of text we want
 Dim RngStt As Range ' This will be the cell with the first  Keywrod1
  Set RngStt = Ws1.Range("A1:A" & Lr & "").Find(What:="Keywrod1", After:=Ws1.Range("A" & Lr & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
Rem 4 main text manipulation
'4a)
    Do While Not RngStt Is Nothing ' This the main outer loop will terminate if we find no new first keyword #####
    Dim RngStp As Range ' This willl be the cell with the next  Keyword2
     Set RngStp = Ws1.Range("A" & RngStt.Row + 1 & ":A" & Lr & "").Find(What:="Keyword2", After:=Ws1.Range("A" & RngStt.Row + 1 & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        If RngStp Is Nothing Then Exit Do  ' This is for the case of if there is no Keyword2  after  a found  Keywrod1
'4b)
    Dim Rw As Long
        For Rw = RngStt.Row To RngStp.Row Step 1 ' We loop through the cells in between and including the cells with  Keywrod1  and  keyword2
        Dim NewCelStr As String ' This is used to build the string for a new cell
         Let NewCelStr = NewCelStr & Ws1.Range("A" & Rw & "").Value2 & vbLf  ' Add the next cell text followed by a new line character
        Next Rw
     Let NewCelStr = Left(NewCelStr, Len(NewCelStr) - 1)
    Dim Lr2 As Long: Let Lr2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
     Let Ws2.Range("A" & Lr2 + 1 & "").Value = NewCelStr
'4c(ii)
     Let NewCelStr = ""
     Set RngStt = Ws1.Range("A" & RngStp.Row & ":A" & Lr + 1 & "").Find(What:="Keywrod1", After:=Ws1.Range("A" & RngStp.Row + 1 & ""), LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
    Loop ' While Not RngStt = Nothing '  ### Main outer loop terminates when main text manipulation is finished ##
 
 
 Ws2.Columns(1).WrapText = False
End Sub