Multiple lines of text in one cell need macro to format the data

[Cantrecallmyusername]

Hi there,

I have data in column A where there are multiple varying lines of text within each cell. In column B and C I have one line of text.
Using a macro I want to split all the data in Column A into one line of text equal to one line of text and align the corresponding value in column B and C to the row.

Using the below code I can take the values in Column A and split them into rows however I cant seem to add the original values in column B and C to this

Sub Format_text()

Dim cell_value As Variant
Dim counter As Integer

'Row counter
counter = 1

'Looping trough A column define max value
For i = 1 To 500

    'Take cell at the time
    cell_value = ThisWorkbook.ActiveSheet.Cells(i, 1).Value

    'Split cell contents
    Dim WrdArray() As String
    WrdArray() = Split(cell_value, vbLf)

    'Place values to the B column
    For Each Item In WrdArray
        ThisWorkbook.ActiveSheet.Cells(counter, 2).Value = Item
        counter = counter + 1
    Next Item

Next i
End Sub

Sample of the data

Cat Dog ZxxxxxxFxxxxxx xxxxxxRxxxxxxS xxxxxxOxxxxxx xxxxxxOxxxxxx 3 xxxxxx	Need this one	Need this one too
Apple Fruit Berry Ice Cream Pear Orange	Include Me	Include Me too

 

[rlv01]

Your description is confusing. Instead of saying "need this one", show an example. Use your "cat, dog, ..." data in cell A1 to show us exactly what you expect to be placed in column B & C.

 

[Cantrecallmyusername]

Your description is confusing. Instead of saying "need this one", show an example. Use your "cat, dog, ..." data in cell A1 to show us exactly what you expect to be placed in column B & C.

Hi,
Apologies if it was somewhat confusing. Below is what I would like the end data to look like; You can see from the above starting point - in Cell A1 there are multiple lines of text - I require this to split out into multiple cells and the corresponding value in B1 and C1 to be associated with the original values in Cell A1.

I hope that is more clear.

Cat	Need this one too	Need this one too
Dog	Need this one too	Need this one too
ZxxxxxxFxxxxxx	Need this one too	Need this one too
xxxxxxRxxxxxxS	Need this one too	Need this one too
xxxxxxOxxxxxx	Need this one too	Need this one too
xxxxxxOxxxxxx 3	Need this one too	Need this one too
xxxxxx	Need this one too	Need this one too
Apple	Include Me	Include Me too
Fruit	Include Me	Include Me too
Berry	Include Me	Include Me too
Ice Cream	Include Me	Include Me too
Pear	Include Me	Include Me too
Orange	Include Me	Include Me too

 

[Cantrecallmyusername]

Using other values as requested...

Cat	Value 1	Value 2
Dog	Value 1	Value 2
ZxxxxxxFxxxxxx	Value 1	Value 2
xxxxxxRxxxxxxS	Value 1	Value 2
xxxxxxOxxxxxx	Value 1	Value 2
xxxxxxOxxxxxx 3	Value 1	Value 2
xxxxxx	Value 1	Value 2
Apple	Value 3	Value 4
Fruit	Value 3	Value 4
Berry	Value 3	Value 4
Ice Cream	Value 3	Value 4
Pear	Value 3	Value 4
Orange	Value 3	Value 4

 

[Fluff]

How about

Sub cantrecall()
   Dim Ary As Variant, Nary As Variant, Sp As Variant
   Dim r As Long, nr As Long, i As Long
   
   Ary = Range("A1:C" & Range("A" & Rows.Count).End(xlUp).Row).Value2
   ReDim Nary(1 To Rows.Count - 2, 1 To 3)
   
   For r = 1 To UBound(Ary)
      Sp = Split(Ary(r, 1), vbLf)
      For i = 0 To UBound(Sp)
         nr = nr + 1
         Nary(nr, 1) = Sp(i)
         Nary(nr, 2) = Ary(r, 2)
         Nary(nr, 3) = Ary(r, 3)
      Next i
   Next r
   Range("E1").Resize(nr, 3).Value = Nary
End Sub

 

[RoryA]

FWIW, since you have 365 you could do this with PowerQuery/Get and Transform.

 

[Cantrecallmyusername]

How about

Sub cantrecall()
   Dim Ary As Variant, Nary As Variant, Sp As Variant
   Dim r As Long, nr As Long, i As Long
  
   Ary = Range("A1:C" & Range("A" & Rows.Count).End(xlUp).Row).Value2
   ReDim Nary(1 To Rows.Count - 2, 1 To 3)
  
   For r = 1 To UBound(Ary)
      Sp = Split(Ary(r, 1), vbLf)
      For i = 0 To UBound(Sp)
         nr = nr + 1
         Nary(nr, 1) = Sp(i)
         Nary(nr, 2) = Ary(r, 2)
         Nary(nr, 3) = Ary(r, 3)
      Next i
   Next r
   Range("E1").Resize(nr, 3).Value = Nary
End Sub

That works perfectly

 

[Fluff]

Glad we could help & thanks for the feedback.