vbaデータの下線を抽出する

Question

私はすべての下線を見つけることができますが、 "（"。でスペースを確認するために配列を操作する方法はありますか？ " 「？のみ以下の例では 『hello』を抽出することになるが、 『用』と 『「（』これら二つが続いているわけではないだろうので、」ん。

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