Array split and extract vba excel - arrays

Question

I got help with this code but when it runs it does not execute what it needs to do. I'm trying to extract words that are underlined and italicized from row C of the first sheet and move them to the secondsheet. The expected outcome is in the second image. Would array splitting be of use in this situation? Hopefully the sample data make it more clear.
Sub proj()
For Each cl In Range("C1:C5")
Call CopyItalicUnderlined(cl, Worksheets("Sheet2").Range("A1"))
Next
End Sub
Sub CopyItalicUnderlined(rngToCopy, rngToPaste)
rngToCopy.Copy rngToPaste
Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
With rngToPaste.Characters(i, 1)
If Not .Font.Italic And Not .Font.Underline Then
.Text = vbNullString
End If
End With
Next
End Sub

Answer 1

Split() could help, but only after you already found out and parsed italic words since Characters() method can be called on Range object only
you could then try the following code:
Option Explicit
Sub proj()
Dim dataRng As range, cl As range
Dim arr As Variant
Set dataRng = Worksheets("ItalicSourceSheet").range("C1:C5") '<--| change "ItalicSourceSheet" with your actual source sheet name
With Worksheets("ItalicOutputSheet") '<--|change "ItalicOutputSheet" with your actual output sheet name
For Each cl In dataRng
arr = GetItalics(cl) '<--| get array with italic words
If IsArray(arr) Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr) + 1) = Application.Transpose(arr) '<--| if array is filled then write it down to output sheet first blank cell in column "A"
Next
End With
End Sub
Function GetItalics(rng As range) As Variant
Dim strng As String
Dim iEnd As Long, iIni As Long, strngLen As Long
strngLen = Len(rng.Value2)
iIni = 1
Do While iEnd <= strngLen
Do While rng.Characters(iEnd, 1).Font.Italic And rng.Characters(iEnd, 1).Font.Underline
If iEnd = strngLen Then Exit Do
iEnd = iEnd + 1
Loop
If iEnd > iIni Then strng = strng & Mid(rng.Value2, iIni, iEnd - iIni) & "|"
iEnd = iEnd + 1
iIni = iEnd
Loop
If strng <> "" Then GetItalics = Split(Left(strng, Len(strng) - 1), "|")
End Function

Answer 2

It's not the prettiest solution, but you can take each cell, put their contents in an array. Then, make some room, and "unload them" and move along.
I tested with some simple data, but if you have errors, can you show more examples of text/data?
Sub proj()
Dim cl As Range
Dim x As Long
x = 0
For Each cl In Sheets("Sheet1").Range("C1:C5")
Call CopyItalicUnderlined(cl, Worksheets("Sheet2").Range("A1").Offset(x, 0))
x = x + 1
Next
Call breakOutWords
End Sub
Sub CopyItalicUnderlined(rngToCopy As Range, rngToPaste As Range)
Dim foundWords() As Variant
rngToCopy.Copy rngToPaste
Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
With rngToPaste.Characters(i, 1)
Debug.Print .Text
If Not .Font.Italic And Not .Font.Underline Then
If .Text <> " " Then
.Text = vbNullString
Else
.Text = " "
End If
End If
End With
Next
rngToPaste.Value = Trim(rngToPaste.Value)
rngToPaste.Value = WorksheetFunction.Substitute(rngToPaste, " ", " ")
End Sub
Sub breakOutWords()
Dim lastRow As Long, i As Long, k As Long, spaceCounter As Long
Dim myWords As Variant
Dim groupRange As Range
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 1 Step -1
' Determine how many spaces - this means we have X+1 words
spaceCounter = Len(Cells(i, 1)) - Len(WorksheetFunction.Substitute(Cells(i, 1), " ", "")) + 1
If spaceCounter > 1 Then
Set groupRange = Range(Cells(i, 1), Cells(WorksheetFunction.Max(2, i + spaceCounter - 1), 1))
groupRange.Select
myWords = Split(Cells(i, 1), " ")
groupRange.Clear
For k = LBound(myWords) To UBound(myWords)
groupRange.Cells(1 + k, 1).Value = myWords(k)
Next k
Else
' how many new rows will we need for the next cell?
Dim newRows As Long
newRows = Len(Cells(i - 1, 1)) - Len(WorksheetFunction.Substitute(Cells(i - 1, 1), " ", ""))
Range(Cells(i, 1), Cells(i + newRows - 1, 1)).EntireRow.Insert
End If
Next i
End Sub

Answer 3

I think this should work - I modified your code to match your example.
Change the top constants to mark where you want to start appending
into Sheet 2
Change names of Worksheets to match your real life sheets
Change range of cells to check in Set rge = ws1.Range("C8:C100")
Example Code:
Option Explicit
Public Sub ExtractUnderlinedItalicizedWords()
' Where to start appending new words '
Const INSERT_COL As Integer = 1
Const START_AT_ROW As Integer = 1
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rge As Range
Dim cel As Range
Dim c As Object
Dim countChars As Integer
Dim i As Integer
Dim intRow As Integer
Dim strWord As String
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
intRow = START_AT_ROW
' Define the range of cells to check
Set rge = ws1.Range("C8:C100")
For Each cel In rge.Cells
countChars = cel.Characters.count
' Only do this until we find a blank cell
If countChars = 0 Then Exit For
strWord = ""
For i = 1 To countChars
Set c = cel.Characters(i, 1)
With c.Font
If (.Underline <> xlUnderlineStyleNone) And (.Italic) Then
strWord = strWord & c.Text
Else
If Len(strWord) > 0 Then
ws2.Cells(intRow, INSERT_COL).Value = strWord
intRow = intRow + 1
strWord = ""
End If
End If
End With
Next i
' Get Last Word in cell
If Len(strWord) > 0 Then
ws2.Cells(intRow, INSERT_COL).Value = strWord
intRow = intRow + 1
strWord = ""
End If
Next ' Next cell in column range
End Sub