Быстрое добавление закладки

[Aent]

Вот так несколько более универсально

Sub QuickBookmark()
    Dim sBmName As String
    Dim i As Long
    sBmName = Selection.Text
    'Заменяем не буквы и не цифры на подчёркивание
    For i = 1 To Len(sBmName)
        Select Case Asc(Mid$(sBmName, i, 1))
            Case 48 To 57        '0-9
            Case 65 To 90         'A-Z
            Case 97 To 122       'a-z
            Case 192 To 255     'А-я
            Case 168, 184         'Ёё
            Case Else
                     Mid$(sBmName, i, 1) = "_"
        End Select
    Next i
    sBmName = "Z" & sBmName  'На случай если первый символ не буква
    On Error Resume Next
    With ActiveDocument.Bookmarks
        Do While .Exists(sBmName)       'Проверяем нет ли уже закладки с таким именем
            sBmName = sBmName & "_"     'Если есть дописываем в хвост подчёркивание
        Loop
        .Add sBmName, Selection.Range
    End With
End Sub

[Frommerrr]

Теперь я доволен.

[Frommerrr]

Сначала написал, что теперь я доволен, но вот для того, чтобы это было так, хотелось бы на конечном этапе сократить все множество подчеркиваний которые заменили все не буквы и не числа -- до одного (между словами). Это относится к универсальному макросу Aent.

Чтобы закладка из М = 28.29 и М = 24.8; t = 2.5, р < 0.02 была не такой: Z_М___28_29_и_М___24_8__t___2_5__р_ __0_0
А такой: Z_М_28_29_и_М_4_8_t_2_5_р_0_0
Не представляю как это сделать, хоть и пытался в меру своих сил.

[Aent]

Sub QuickBookmark()
    Dim sBmName As String
    Dim i As Long, j As Long
    sBmName = "Z" & Selection.Text
    'Удаляем не буквы и не цифры, заменяя на одиночное подчёркивание
    j = 1
    For i = 1 To Len(sBmName)
        Select Case Asc(Mid$(sBmName, i, 1))
        Case 48 To 57, 65 To 90, 97 To 122, 192 To 255, 168, 184
            Mid$(sBmName, j, 1) = Mid$(sBmName, i, 1)
            j = j + 1
        Case Else
            If Mid$(sBmName, j - 1, 1) <> "_" Then
                Mid$(sBmName, j, 1) = "_"
                j = j + 1
            End If
        End Select
    Next i
    sBmName = Left$(sBmName, j - 1)
    With ActiveDocument.Bookmarks
        Do While .Exists(sBmName)       'Проверяем нет ли уже закладки с таким именем
            sBmName = sBmName & "_"     'Если есть дописываем в хвост подчёркивание
        Loop
        .Add sBmName, Selection.Range
    End With
End Sub

[Frommerrr]

Это то, чего я добивался. Спасибо Aent и viter.alex за помощь!