Array split and extract vba excel

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