vba提取數據下劃線

Question

我能夠找到所有的下劃線，但我希望能夠消除那些後跟「（」。我怎樣操縱數組來檢查一個空間，然後「（ 「？在下面只例如‘你好’將被提取，但‘爲’與‘做’不會，因爲這兩個後跟一個」（」。

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

變化

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) & "|" 

Answer 2

我會在函數內部構建數組。

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