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