Excel实战技巧80： 添加可视化的指示标志

'在所选文本开头添加三角指示标志
Sub TextTickmark_Triangle()
  Dim cell As Range
  Dim TextFont As String
  Dim TickChar As String
  Dim TickColor As Long
  Dim BoldArray() As Variant
  Dim BoldOffset As Integer
  Dim y As Long
  Dim x As Long
 
  '确定方向和颜色
   If TypeName(Selection) <>"Range" Then Exit Sub
 
  '遍历所选区域的每个单元格
  For Each cell In Selection.Cells
       
    '存储字体类型
    TextFont = cell.Characters(1, 1).Font.Name
 
    '确定要添加的标志颜色/类型
    If TextFont = "Wingdings 3" Then
      Select Case Left(cell.Text, 2)
        Case "p "
          '红色
          TickColor = -16776961
          TickChar = "q "
          BoldOffset = 0
        Case "q "
          '橙色
          TickColor = 49407
          TickChar = "u "
          BoldOffset = 0
          '重置
        Case "u "
          TickColor = 0
          TickChar = ""
          BoldOffset = -2
        Case Else
          Exit Sub
      End Select
    Else
      '绿色
      TickColor = -11489280
      TickChar = "p "
      BoldOffset = 2
    End If
 
    '重置Bold Character数组
    Erase BoldArray
    ReDim BoldArray(0)
    y = 0
     
    '记录在文本中的粗体字符
    For x = 1 To Len(cell.Text)
      If cell.Characters(x, 1).Font.FontStyle ="Bold" Then
        ReDim Preserve BoldArray(y)
        BoldArray(y) = x + BoldOffset
        y = y + 1
      End If
    Next x
   
    '从文本中移除前一个标志
    If TickChar <> "p " Then
      cell.Font.Color = cell.Characters(3,1).Font.Color
      cell.Font.Name = cell.Characters(3,1).Font.Name
      cell.FormulaR1C1 = Right(cell.Text,Len(cell.Text) - 2)
    End If
     
    '添加标志
    If TickChar <> "" Then
      cell.FormulaR1C1 = TickChar & cell.Text
      '确保文本不是粗体
      cell.Font.FontStyle = "Normal"
       
      With cell.Characters(Start:=1,Length:=1).Font
        .Name = "Wingdings 3"
        .Color = TickColor
      End With
    End If
   
    '重新将文本中原粗体字符加粗
    If Not IsEmpty(BoldArray(0)) Then
      For x = LBound(BoldArray) ToUBound(BoldArray)
        cell.Characters(Start:=BoldArray(x),Length:=1).Font.FontStyle = "Bold"
      Next x
    End If
      
  Next cell
End Sub