创建超链接

Sub 创建超链接()
'
' 创建超链接 宏
' 为所选择的表格的第一列的cmdlet命令创建对应的超链接（前提是已经存在对应的命令说明内容）
' 只处理第一个表格
'
    Application.ScreenUpdating = False                          '关闭同步调整更新

    
    Dim my_table As Table
    If (0 = Selection.Tables.Count) Then
        '所选内容没有表格存在
        MsgBox ("所选内容没有表格存在")
        Exit Sub
    End If
    Set my_table = Selection.Tables(1)
    Dim table_Rows As Long
    table_Rows = my_table.Rows.Count
    Dim row_index As Long
    row_index = 1
    
    Dim regex As Object '声明
    Set regex = CreateObject("VBScript.RegExp") '创建正则对象
    With regex:
        .Pattern = "^[\w-]+"                  '设置正则表达式
    End With
    
    
    Do
        Dim temp_str As String
        temp_str = my_table.Cell(row_index, 1).Range.Text
        Dim my_Matches As Object
        Set my_Matches = regex.Execute(temp_str)
        If (0 < my_Matches.Count) Then
            Result = select_range("cmdlet 命令", "Server 2016 core")    '选择查询范围，否则会因为之前选择了表格导致找不到
            Selection.Find.ClearFormatting  '清除之前的查询格式、选项
            '设置现在的查询格式
            With Selection.Find
                .Style = ActiveDocument.Styles("标题 2")
                .Forward = True
                .Wrap = wdFindContinue
                .Format = True
                .MatchCase = False          '是否区分大小写
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .MatchWholeWord = True      '是否全字匹配
                .MatchPrefix = True         '匹配前缀
                .MatchSuffix = True         '匹配后缀
                .Text = my_Matches(0).Value
                If (.Execute) Then
                    Selection.Copy
                    '要定位到表格中
                    my_table.Cell(row_index, 1).Select
                    'Selection.Delete
                    CreateObject("Excel.Application").Wait (Now + TimeValue("00:00:01"))    '必须加上延时，否则会报运行时错误4198
                    Selection.PasteSpecial Link:=True, DataType:=wdPasteHyperlink
                    
            End If
            End With
        End If
        
        row_index = row_index + 1
    Loop While row_index <= table_Rows
    Application.ScreenUpdating = True                          '开启同步调整更新
    
End Sub