vba提取数据下划线

我能够find所有的下划线，但我想能够消除后面跟着一个“（”。我怎样才能操纵数组来检查一个空间，然后“（”？只在下面的例子“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

更改

 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

我将在函数中构build数组。

 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