CODEWITHSUNDEEP
arraysvbaexcel
johndoe253
johndoe253

Reputation: 237

Array splitting and extracting

I'm attempting to go through each character in a cell to determine whether or not a word is underlined and italicized but so far the loop runs and freezes. How can I copy and move the word that is italicized and underlined? This is what I have so far. I asked a new question because I wasn't clear enough in this one. It can be accessed at Array split and extract vba excel .

For Each j In ActiveSheet.Range("C1:C105")
        v = Trim(j.Value)
        If Len(v) > 0 Then
            v = Replace(v, vbLf, " ")

            Do While InStr(v, "  ") > 0
                v = Replace(v, "  ", " ")
            Loop

            arr = Split(v, " ")

            For Z = LBound(arr) To UBound(arr)
            e = arr(Z)

                For i = 1 To Len(v)
                    If j.Characters(i, 1).Font.Italic = True And j.Characters(i, 1).Font.Underline = True Then
                        j.Value.Copy


                    End If
                Next i
            Next Z
        End If
   Next j​

Upvotes: 2

Views: 101

Answers (3)

David Zemens
David Zemens

Reputation: 53663

A slightly simpler implementation involves copying the entire cell values first, and then manipulating the copied range. Call this in a loop, and provide it the two arguments: rngToCopy = the cell being copied and rngToPaste the destination cell (qualified to specific workbook/worksheet):

For each cl in Range("C1:C105")
    Call CopyItalicUnderlined(cl, __Some Place Else__)
Next

Here's the procedure

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

Upvotes: 1

Ralph
Ralph

Reputation: 9444

The following piece of code will Debug.Print all the words that are underlined and formatted italic in any of the given cells:

Option Explicit

Public Sub tmpSO()

Dim i As Long
Dim j As Range
Dim StartPoint As Long
Dim InItalicUnderlinedWord As Boolean

For Each j In ThisWorkbook.Worksheets(1).Range("C1:C105")
    If Len(j.Value2) > 0 Then
        For i = 1 To Len(j.Value2)
            If j.Characters(i, 1).Font.Italic And j.Characters(i, 1).Font.Underline Then
                If InItalicUnderlinedWord = False Then
                    StartPoint = i
                    InItalicUnderlinedWord = True
                End If
            Else
                If InItalicUnderlinedWord = True Then
                    Debug.Print Mid(j.Value2, StartPoint, i - StartPoint)
                    InItalicUnderlinedWord = False
                End If
            End If
            If InItalicUnderlinedWord = True And i = Len(j.Value2) Then
                Debug.Print Mid(j.Value2, StartPoint, i - StartPoint + 1)
                InItalicUnderlinedWord = False
            End If
        Next i
    End If
Next j

End Sub

Debug.Print will output the italic and underlined word into the immediate window of the VBE. If you want these words anywhere else then you'll have to adjust the code in two (!) places:

  1. Once in the section which starts with InItalicUnderlinedWord for any find anywhere within a cell and
  2. in the section which starts with If InItalicUnderlinedWord = True And i = Len(j.Value2) Then for any occurrences where the last character in a cell is also underlined and italic.

Let me know if you have any questions or problems.

Upvotes: 2

Nathan_Sav
Nathan_Sav

Reputation: 8531

something like this, only does 1 cell, so you'll need to add it to your loop

Sub test()

Dim r As Range
Dim v As Variant
Dim i As Integer
Dim f As Integer

Set r = Range("h2")
v = Split(r.Value, Chr(32))

For i = 0 To UBound(v) - 1

    f = InStr(1, r, v(i))     ' equiv Application.WorksheetFunction.Search(v(i), r)

    If r.Characters(f, 1).Font.Italic Then
        Debug.Print v(i) & " is italic"
    End If

Next i

End Sub

Upvotes: 1

Related Questions