VBA真有意思，分享一下常用的快捷功能，需要的可以自己添加到菜单

在特定字符后增加指定字符
 Sub AddSymbolToText()
    ' 定义变量
    Dim rng As Range
    Dim cell As Range
    Dim symbol As String
    Dim searchText As String
    
    ' 获取用户输入的符号和要搜索的文字
    symbol = InputBox("请输入要添加的符号:", "添加符号")
    searchText = InputBox("请输入要查找的文字:", "查找文字")
    
    ' 获取当前选定的区域
    Set rng = Selection
    
    ' 遍历选定区域内的每一个单元格
    For Each cell In rng
        ' 检查单元格是否包含指定的文字
        If InStr(1, cell.Value, searchText) > 0 Then
            ' 在指定的文字后添加符号
            cell.Value = Replace(cell.Value, searchText, searchText & symbol)
        End If
    Next cell
End Sub

突出显示＞指定值

 Sub HighlightCellsGreaterThanValue()
    ' 定义变量
    Dim selectedRange As Range
    Dim cell As Range
    Dim specifiedValue As Double
    Dim highlightColor As Long
    
    ' 获取用户输入的数值
    specifiedValue = InputBox("请输入要比较的数值:", "数值比较")
    
    ' 获取用户选定的范围
    Set selectedRange = Selection
    
    ' 设置突出显示的颜色
    highlightColor = RGB(255, 0, 0) ' 红色
    
    ' 遍历选定范围内的每个单元格
    For Each cell In selectedRange
        ' 如果单元格的值大于指定的数值，则突出显示该单元格
        If cell.Value > specifiedValue Then
            cell.Interior.Color = highlightColor
        End If
    Next cell
End Sub

突出显示＜指定数

 Sub HighlightCellsLessThanValue()
    ' 定义变量
    Dim selectedRange As Range
    Dim cell As Range
    Dim specifiedValue As Double
    Dim highlightColor As Long
    
    ' 获取用户输入的数值
    specifiedValue = InputBox("请输入要比较的数值:", "数值比较")
    
    ' 获取用户选定的范围
    Set selectedRange = Selection
    
    ' 设置突出显示的颜色
    highlightColor = RGB(255, 0, 0) ' 红色
    
    ' 遍历选定范围内的每个单元格
    For Each cell In selectedRange
        ' 如果单元格的值小于指定的数值，则突出显示该单元格
        If cell.Value < specifiedValue Then
            cell.Interior.Color = highlightColor
        End If
    Next cell
End Sub

选中所有带批注的单元格

 Sub SelectCellsWithComments()
    ' 定义变量
    Dim selectedRange As Range
    Dim cell As Range
    Dim comment As Comment
    Dim combinedRange As Range
    
    ' 获取用户选定的范围
    Set selectedRange = Selection
    
    ' 初始化combinedRange
    Set combinedRange = Nothing
    
    ' 遍历选定范围内的每个单元格
    For Each cell In selectedRange
        ' 检查单元格是否有批注
        On Error Resume Next ' 忽略错误，如果单元格没有批注
        Set comment = cell.Comment
        On Error GoTo 0 ' 恢复错误处理
        
        ' 如果单元格有批注，则将其添加到combinedRange中
        If Not comment Is Nothing Then
            If combinedRange Is Nothing Then
                Set combinedRange = cell
            Else
                Set combinedRange = Union(combinedRange, cell)
            End If
        End If
    Next cell
    
    ' 如果combinedRange不为空，则选择所有带有批注的单元格
    If Not combinedRange Is Nothing Then
        combinedRange.Select
    Else
        MsgBox "在选定区域内没有找到带有批注的单元格。"
    End If
End Sub

选中区域内空白单元格

 Sub SelectBlanksInSelection()
    ' 定义变量
    Dim rng As Range
    Dim cell As Range
    Dim blankCells As Range

    ' 获取当前选定的区域
    Set rng = Selection

    ' 初始化blankCells变量
    Set blankCells = Nothing

    ' 遍历选定区域内的每一个单元格
    For Each cell In rng
        ' 检查单元格是否为空
        If IsEmpty(cell.Value) Then
            ' 如果单元格为空，将其加入到blankCells中
            If blankCells Is Nothing Then
                Set blankCells = cell
            Else
                Set blankCells = Union(blankCells, cell)
            End If
        End If
    Next cell

    ' 如果找到了空白单元格，选中它们
    If Not blankCells Is Nothing Then
        blankCells.Select
    Else
        MsgBox "选定的区域内没有空白单元格。"
    End If
End Sub

选择非空单元格

 Sub SelectNonBlanksInSelection()
    ' 定义变量
    Dim rng As Range
    Dim cell As Range
    Dim nonBlankCells As Range

    ' 获取当前选定的区域
    Set rng = Selection

    ' 初始化nonBlankCells变量
    Set nonBlankCells = Nothing

    ' 遍历选定区域内的每一个单元格
    For Each cell In rng
        ' 检查单元格是否非空
        If Not IsEmpty(cell.Value) Then
            ' 如果单元格非空，将其加入到nonBlankCells中
            If nonBlankCells Is Nothing Then
                Set nonBlankCells = cell
            Else
                Set nonBlankCells = Union(nonBlankCells, cell)
            End If
        End If
    Next cell

    ' 如果找到了非空单元格，选中它们
    If Not nonBlankCells Is Nothing Then
        nonBlankCells.Select
    Else
        MsgBox "选定的区域内没有非空单元格。"
    End If
End Sub

按类型提取字符
 Sub ExtractCharactersByType()
    ' 定义变量
    Dim userOption As String
    Dim selectedRange As Range
    Dim cell As Range
    Dim resultStartCell As Range
    Dim resultText As String

    ' 获取用户选择的类型
    userOption = InputBox("请选择要提取的字符类型:" & vbCrLf & _
                          "1 - 汉字" & vbCrLf & _
                          "2 - 字母" & vbCrLf & _
                          "3 - 数字" & vbCrLf & _
                          "4 - 空格" & vbCrLf & _
                          "5 - 中文标点" & vbCrLf & _
                          "6 - 英文标点", "字符提取")

    ' 获取用户选定的范围
    Set selectedRange = Selection

    ' 获取用户选择的放置结果的起始单元格
    Set resultStartCell = Application.InputBox("请选择放置提取结果的起始单元格:", "起始单元格", Type:=8)
    If resultStartCell Is Nothing Then
        MsgBox "未选择放置结果的起始单元格。"
        Exit Sub
    End If

    ' 遍历选定范围内的每一行
    Dim rowIndex As Long
    For rowIndex = 1 To selectedRange.Rows.Count
        ' 初始化结果文本
        resultText = ""

        ' 提取当前行的单元格文本
        Dim currentRow As Range
        Set currentRow = selectedRange.Rows(rowIndex)

        ' 遍历行内的每个单元格
        For Each cell In currentRow.Cells
            ' 提取单元格文本
            Dim cellText As String
            cellText = cell.Value ' 这里修改为cell.Value

            ' 根据用户选择的类型提取字符
            Select Case userOption
                Case "1"
                    resultText = resultText & ExtractSimplifiedChineseCharacters(cellText)
                Case "2"
                    resultText = resultText & ExtractLetters(cellText)
                Case "3"
                    resultText = resultText & ExtractNumbers(cellText)
                Case "4"
                    resultText = resultText & ExtractSpaces(cellText)
                Case "5"
                    resultText = resultText & ExtractChinesePunctuation(cellText)
                Case "6"
                    resultText = resultText & ExtractEnglishPunctuation(cellText)
                Case Else
                    MsgBox "无效的选择。"
                    Exit Sub
            End Select
        Next cell

        ' 将提取结果放置在指定位置的列
        resultStartCell.Offset(rowIndex - 1, 0).Value = resultText
    Next rowIndex
End Sub

'提取汉字
Function ExtractSimplifiedChineseCharacters(ByVal text As String) As String
     Dim regex As Object
     Set regex = CreateObject("VBScript.RegExp")
     
     With regex
         .Global = True
         ' 使用正确的 Unicode 范围匹配汉字
         .Pattern = "[\u4E00-\u9FA5]"
     End With
     
     Dim matches As Object
     Set matches = regex.Execute(text)
     
     Dim match As Object
     Dim extractedText As String
     
     For Each match In matches
         extractedText = extractedText & match.Value
     Next match
     
     ExtractSimplifiedChineseCharacters = extractedText
End Function

' 提取字母
Function ExtractLetters(ByVal text As String) As String
    Dim i As Long
    Dim extractedText As String
    For i = 1 To Len(text)
        If UCase(Mid(text, i, 1)) Like "[A-Z]" Then
            extractedText = extractedText & Mid(text, i, 1)
        End If
    Next i
    ExtractLetters = extractedText
End Function

' 提取数字
Function ExtractNumbers(ByVal text As String) As String
    Dim i As Long
    Dim extractedText As String
    For i = 1 To Len(text)
        If Mid(text, i, 1) Like "[0-9]" Then
            extractedText = extractedText & Mid(text, i, 1)
        End If
    Next i
    ExtractNumbers = extractedText
End Function

' 提取空格
Function ExtractSpaces(ByVal text As String) As String
    Dim i As Long
    Dim extractedText As String
    For i = 1 To Len(text)
        If Mid(text, i, 1) = " " Then
            extractedText = extractedText & Mid(text, i, 1)
        End If
    Next i
    ExtractSpaces = extractedText
End Function

' 提取中文标点
Function ExtractChinesePunctuation(ByVal text As String) As String
    Dim i As Long
    Dim extractedText As String
    For i = 1 To Len(text)
        Select Case AscW(Mid(text, i, 1))
            Case 12289, 12290, 12298, 12299, 12300, 12301, 12302, 12303, 12304
                extractedText = extractedText & Mid(text, i, 1)
        End Select
    Next i
    ExtractChinesePunctuation = extractedText
End Function

' 提取英文标点
Function ExtractEnglishPunctuation(ByVal text As String) As String
    Dim i As Long
    Dim extractedText As String
    For i = 1 To Len(text)
        Select Case Asc(Mid(text, i, 1))
            Case 33 To 47, 58 To 64, 91 To 96, 123 To 126
                extractedText = extractedText & Mid(text, i, 1)
        End Select
    Next i
    ExtractEnglishPunctuation = extractedText
End Function