VBA：選擇單元格中的文本，直到下一個字符爲粗體

Question

我試圖選擇Microsoft Word中表格單元格內的子標題下的所有文本。當文本之後有子標題時它工作正常，但如果它是單元格中的最後一個子標題，它將選擇整個單元格。有沒有辦法檢查Selection.Next的細胞結束？

這是到目前爲止我的代碼：

Public Sub copySubHeading() 
    Selection.HomeKey Unit:=wdStory 
    With Selection.Find 
     .ClearFormatting 
     .MatchCase = False 
     .Text = "Example:" 
     .Wrap = wdFindContinue 
     .Font.Bold = True 
     .Execute 
    End With 
    Selection.MoveRight Unit:=wdCell, Count:=1, Extend:=wdMove 
    With Selection.Find 
     .ClearFormatting 
     .MatchCase = False 
     .Text = "Heading 6:" 
     .Wrap = wdFindContinue 
     .Font.Bold = True 
     .Execute 
    End With 
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdMove 
    While IsAlphanumericCharacter(Selection) <> True 
     Selection.Next(Unit:=wdCharacter, Count:=1).Select 
    Wend 
    While Not Selection.Next.Bold 
     Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend 
    Wend 
End Sub 

Private Function IsAlphanumericCharacter(character As String) As Boolean 
    Select Case Asc(character) 
     Case 48 To 57, 65 To 90, 97 To 122 
      IsAlphanumericCharacter = True 
     Case Else 
      IsAlphanumericCharacter = False 
    End Select 
End Function 

當細胞與任何這個特殊字符是在下面的圖片中結束這上面的代碼將工作，雖然我有細胞與不結束工作這個角色每一次。

大部分時間單元格將以下面單元格末尾的字符結尾。

有沒有方法可以選擇文本，直到粗體字符或單元格的結尾？

或者，如果有人可以提供更好的方式來選擇所有的文字，直到下一個非常有用的標題，謝謝。

Answer 1

我能用下面的代碼解決問題。它需要添加一個字符計數器來檢查整個單元格被選中的時間。

這不是最好的，但它能完成這項工作。如果任何人遇到更簡單的方式，請讓我知道。

Public Sub copySubHeading(subheading As String) 
    Selection.HomeKey Unit:=wdStory 
    With Selection.Find 
     .ClearFormatting 
     .MatchCase = False 
     .Text = "Example:" 
     .Wrap = wdFindContinue 
     .Font.Bold = True 
     .Execute 
    End With 
    Selection.MoveRight Unit:=wdCell, count:=1, Extend:=wdMove 
    With Selection.Find 
     .ClearFormatting 
     .MatchCase = False 
     .Text = subheading 
     .Wrap = wdFindContinue 
     .Font.Bold = True 
     .Execute 
    End With 
    If Selection.Find.Found Then 
     Selection.MoveRight Unit:=wdCharacter, count:=1, Extend:=wdMove 
     moveSelectionUntilOnAlphanumericCharacter 
     extendSelectionUntilNextHeadingOrCountMet Selection.Range 
     Selection.Copy 
    End If 
End Sub 

Private Sub extendSelectionUntilNextHeadingOrCountMet(selection As Range, Optional count As Integer = -1) 
    Dim characterCount As Integer 
    Dim startPoint As Range 
    Set startPoint = selection 
    startPoint.Select 
    characterCount = 1 

    Do While Not (Selection.Next = ":" And Selection.Next.Bold) 
     Selection.MoveRight Unit:=wdCharacter, Extend:=wdExtend 
     characterCount = characterCount + 1 
     If Selection.Characters.count <> characterCount Then 
      characterCount = characterCount - 1 
      Selection.Collapse 
      extendSelectionUntilNextHeadingOrCountMet startPoint, characterCount 
      Exit Do 
     End If 
     If characterCount = count Then 
      Exit Do 
     End If 
    Loop 
    reduceSelectionUntilNotOnBoldCharacterOrPreviousHeader 
End Sub 

Private Sub reduceSelectionUntilNotOnBoldCharacterOrPreviousHeader() 
    Do While Selection.Next.Bold And Selection.Previous <> ":" 
     Selection.MoveLeft Unit:=wdCharacter, Extend:=wdExtend 
    Loop 
End Sub 

Private Sub moveSelectionUntilOnAlphanumericCharacter() 
    Do While IsAlphanumericCharacter(Selection) <> True 
     Selection.Next(Unit:=wdCharacter, count:=1).Select 
    Loop 
End Sub 

Private Function IsAlphanumericCharacter(character As String) As Boolean 
    Select Case Asc(character) 
     Case 48 To 57, 65 To 90, 97 To 122 
      IsAlphanumericCharacter = True 
     Case Else 
      IsAlphanumericCharacter = False 
    End Select 
End Function 

希望有人會在未來找到這個有用的。