office交流網--QQ交流群號

Access培訓群:792054000         Excel免費交流群群:686050929          Outlook交流群:221378704    

Word交流群:218156588             PPT交流群:324131555

爲單元格裡的各箇文字設置不衕的字體和顔色(甚至可以隱藏部分數據而實現加密保密數據的功能)

2020-05-29 08:00:00
zstmtony
原創
3324


  Dim strText As String
  Dim intLen As Integer
  Dim i As Integer
  Dim strResult As String
  Dim intTimes As Integer
  Dim intPos As Integer
  Dim strConfuseCode As String
  Dim strPos As String  ' 0,3,5,8
  Dim varPos As Variant
  Dim intStart As Integer
  Dim intCellStart As Integer
  strPos = "3,5"
  varPos = Split(strPos, ",")
  strText = Range("G2").Text
 
  intStart = 1
  For i = 0 To UBound(varPos)
    intPos = varPos(i)
    If intPos = 0 Then
       strConfuseCode = getRndChar(5)
       intLen = Len(strConfuseCode)
       Range("H2") = Range("H2") & strConfuseCode
    Else
       intCellStart = Len(Range("H2").Text) + 1
       Range("H2").Value = Range("H2").Value & Mid(strText, intStart, intPos - intStart + 1)
      
       Range("H2").Characters(intCellStart, intPos - intStart + 1).Font.Size = 11
       Range("H2").Characters(intCellStart, intPos - intStart + 1).Font.Color = vbBlack
      
       intStart = intPos + 1
       intCellStart = Len(Range("H2").Text) + 1
       strConfuseCode = getRndChar(5)
       intLen = Len(strConfuseCode)
       Range("H2").Value = Range("H2").Value & strConfuseCode
       Range("H2").Characters(intCellStart, intLen).Font.Size = 1
       Range("H2").Characters(intCellStart, intLen).Font.Color = vbWhite
      
    End If
  Next
  intStart = intPos + 1
  intCellStart = Len(Range("H2").Text) + 1
  Range("H2").Value = Range("H2").Value & Mid(strText, intStart)  '隻要一賦值,就會清除裡麵爲獨立內容設置字體的格式。所以必鬚 先一次性設置好value,再設置格式
  Range("H2").Characters(intCellStart, Len(Range("H2").Text) - intStart + 1).Font.Size = 11
       Range("H2").Characters(intCellStart, Len(Range("H2").Text) - intStart + 1).Font.Color = vbBlack


可以實現 可以隱藏部分數據而實現加密保密數據的功能

也可實現 爲現有數據加上混淆碼 或榦擾碼,達到避免被人直接複製數據的效果。卽直接複製數據中會有榦擾碼。但顯示正常

分享