Option Explicit

Sub Document_Open()
  With ListBox1
    .Clear
    .MultiSelect = fmMultiSelectMulti
    .AddItem "Accupuncturist"
    .AddItem "Chiropractor"
    .AddItem "Dietician"
    .AddItem "Massage Therapist"
    .AddItem "Naturopath"
    .AddItem "Osteopath"
    .AddItem "Psychologist/Social worker"
    .AddItem "Physiotherapist"
    .AddItem "Podiatrist/Chiropractor"
    .AddItem "Speech Therapist"
  End With
End Sub

Private Sub CommandButton1_Click()
Dim i As Long, StrOut As String
For i = 0 To ListBox1.ListCount - 1
  If ListBox1.Selected(i) Then
    StrOut = StrOut & ListBox1.List(i) & vbCr
  End If
Next i
Call UpdateBookmark("bm1", StrOut)
Sub UpdateBookmark(StrBkMk As String, StrTxt As String)
Dim BkMkRng As Range
With ActiveDocument
  If .Bookmarks.Exists(StrBkMk) Then
    Set BkMkRng = .Bookmarks(StrBkMk).Range
    BkMkRng.Text = StrTxt
    .Bookmarks.Add StrBkMk, BkMkRng
  End If
End With
Set BkMkRng = Nothing
End Sub