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
Reply With Quote
Bookmarks