Extract Bold text from string

macropod · #8 04-17-2019, 03:03 PM

The code to get all headings of a particular Style might look like:

Code:

Private Sub UserForm_Initialize()
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .Style = wdStyleHeading1
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    cboContractForm.AddItem Split(.Range.Text, vbCr)(0)
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub

In this case, the code will populate a dropdown with all "Heading 1" text - which is what you might use for 'Contract 1', 'Contract 2', etc.

Having chosen the contract, you might then use code like the following to get its items:

Code:

Sub Get_Items()
Dim Rng As Range
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = cboContractForm.Value
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .Style = wdStyleHeading1
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Set Rng = .Duplicate
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .Style = wdStyleHeading2
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      If .InRange(Rng) Then
        'Code to populate checkbox captions goes here
      Else
        Exit Do
      End If
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
End Sub

and code like:

Code:

Sub Delete_Contracts()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .Style = wdStyleHeading1
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      If Split(.Text, vbCr) <> cboContractForm.Value Then
        Set Rng = .Duplicate
        Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        Rng.Text = vbNullString
      End If
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub

to delete the unwanted headings.

Then, when you've selected the items, you might use code like the following to delete any unwanted items:

Code:

Sub Delete_Items()
Application.ScreenUpdating = False
Dim Ctrl As Control, StrItems As String, Rng As Range
For Each Ctrl In Me.Controls
  With Ctrl
    If .Name Like "ContractItem#*" Then
      If .Value = 0 Then
        If .Caption = "" Then
          StrItems = StrItems & "|" & .Caption & "|"
        End If
      End If
    End If
  End With
Next
MsgBox StrItems
Exit Sub
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .Style = wdStyleHeading2
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      If InStr(StrItems, "|" & Split(.Text, vbCr) & "|") > 0 Then
        Set Rng = .Duplicate
        Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        Rng.Text = vbNullString
      End If
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub

The above assumes the checkboxes are named ContractItem1, ContractItem2, etc.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Formula to Extract text from a text string	Haha88	Excel	2	11-14-2017 01:32 AM
Extract text from a text string	Haha88	Excel	8	02-13-2017 05:06 PM
Extract a string from a paragraph	kirkm	Word VBA	7	09-11-2016 06:13 PM
Extract numbers from a text string	aleale97	Excel	4	02-10-2011 10:33 AM
Extract from String using Wildcard	whousedmy	Word	0	05-21-2009 01:35 AM