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

Looks complicated. You only want to look at actual words not include punctuation - and you want to look at formatting. Probably need some kind of regular expression and then be able to look at formatting based on the posiition of the word in the cell — dbmitch
– dbmitch, Commented Aug 3, 2016 at 17:46
Add example code using your definitions - no need for reg expressions — dbmitch
– dbmitch, Commented Aug 3, 2016 at 18:24
You're not changing the destination range within the loop. If you do it that way, there will only be one output value on Sheet2... — David Zemens
– David Zemens, Commented Aug 3, 2016 at 18:25

user3598756 · Accepted Answer · 2016-08-03 18:23:13Z

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

answered Aug 3, 2016 at 18:23

user3598756

29.5k4 gold badges20 silver badges30 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

johndoe253 Over a year ago

Thank you! Just to clarify, how could I move it to start at V4?

user3598756 Over a year ago

What should start ar V4?

BruceWayne · Accepted Answer · 2016-08-03 18:22:07Z

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

dbmitch · Accepted Answer · 2016-08-03 18:23:29Z

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

Collectives™ on Stack Overflow

Array split and extract vba excel

3 Answers 3

2 Comments

2 Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

2 Comments

2 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related