vba提取数据下划线

Question

我能够找到所有下划线但是我希望能够消除后面跟着“（”。那么我如何操纵数组来检查空格然后“（”？以下示例仅提取“hello”，但“for”和“do”不会，因为这两个后跟“（”。

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 1

我会在函数中构建数组。

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")
        For Each cl In dataRng
            If CBool(Len(cl.Value2)) Then
                arr = getUnderlinedItalics(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"
            End If
        Next
    End With
End Sub

Function getUnderlinedItalics(rng As Range, _
                              Optional non As String = " (") As Variant
    Dim str As String, tmp As String, a As Long, p As Long, ars As Variant

    'make sure that rng is a single cell
    Set rng = rng(1, 1)

    'initialize array
    ReDim ars(a)

    'create a string that is longer than the original
    str = rng.Value2 & Space(Len(non))

    For p = 1 To Len(rng.Value2)
        If rng.Characters(p, 1).Font.Italic And rng.Characters(p, 1).Font.Underline Then
            tmp = tmp & Mid(str, p, 1)
        ElseIf CBool(Len(tmp)) And Mid(str, p, 2) <> non Then
            ReDim Preserve ars(a)
            ars(a) = tmp
            a = a + 1: tmp = vbNullString
        Else
            tmp = vbNullString
        End If
    Next p

    getUnderlinedItalics = ars
End Function

Answer 2

变化

If iEnd > iIni Then strng = strng & Mid(rng.Value2, iIni, iEnd - iIni) & "|"

到

If iEnd > iIni Then If Mid(rng.Value2, iIni + iEnd - iIni, 2) <> " (" Then strng = strng & Mid(rng.Value2, iIni, iEnd - iIni) & "|"