如何批量设置EXCEL某个单元格内数字后几位的颜色（用VBA或者函数都可以）

Question

例如 单元格里面的数字如下
332456432.434
65289.322
873924321.209
首先要把数字转成文本格式，然后把小于万位的数字都变成灰色，其他是黑色。希望通过宏或者VBA可以批量设置。

Answer 1

我再来一个更短更快一点的：
打开你的excel表，假设你的数据在sheet1，按ALT+F11，进入VBE，双击左上角的sheet1，在右侧的空白处录入下面的代码。

Sub aa()
For Each c In UsedRange '遍历所以有数据的区域
If Len(c.Value) > 0 Then '如果单元格不为空值，进行变色
c.Value = "'" & c.Value '将单元格数字转换成文本
If Int(c.Value) - c.Value <> 0 Then '如果是小数，就取得小数点前面的4位和小数点后面的文本变色
xsd = InStr(c.Value, ".") '取得小数点在第几位
l = Len(c.Value) '取得单元格数字的长度
c.Characters(xsd - 4, l - xsd + 5).Font.Color = 8355711 '变色
Else '如果是整数，就将后面的4位文本变色
k = Len(c.Value)
c.Characters(k - 3, 4).Font.Color = 8355711
End If
End If
Next
End Sub

关闭VBE窗体，回到sheet1，按ALT+F8，选择sheet1.aa执行即可

Answer 2

Sub 选择区域万位以下变为灰色()
'同时小数点后面设置为2位。
Dim r1 As Range
Dim i, q, l, k As Long
Dim p As String
Selection.NumberFormatLocal = "@"
Selection.HorizontalAlignment = xlRight
For Each r1 In Selection
r1.Select
r1 = Format(r1.Text, "0.00")
p = r1.Text
l = InStrRev(p, ".")
k = Len(p)
If l = 0 Then l = k + 1
With ActiveCell.Characters.Font
.ColorIndex = 1
End With
With ActiveCell.Characters(Start:=l - 4, Length:=k - l + 5).Font
.ColorIndex = 15
End With
Next r1
End Sub本回答被提问者采纳

Answer 3

Sub 万位以下变为灰色()
Dim i, q, l, k As Long
Dim p As String
For q = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, q).End(xlUp).Row
Cells(i, q).Select
With ActiveCell.Characters.Font
.ColorIndex = 1
End With
If IsNumeric(Cells(i, q).Value) Then
Selection.NumberFormatLocal = "@"
If Cells(i, q).Value > 10000 Then
p = Cells(i, q).Value
If InStr(p, ".") = 0 Then
p = p & ".00"
Cells(i, q).Value = p
End If
l = InStrRev(p, ".")
k = Len(p)
With ActiveCell.Characters(Start:=l - 4, Length:=k - l + 5).Font
.ColorIndex = 16
End With
Else
With ActiveCell.Characters(Start:=1, Length:=k).Font
.ColorIndex = 16
End With
End If
End If
Next
Next
End Sub追问

在单元格里的内容原本是数字的情况下如何自动转成文本后执行上述代码呢？我用你这个执行后不行，只有手动去把每个数字都转成文本后执行了才有效

Answer 4

Sub color()
For i = 1 To 100 '假设100行，100列
For j = 1 To 100

With Cells(i, j).Characters.Font '全部弄成黑色
.ColorIndex = 1
End With
Cells(i, j).NumberFormatLocal = "@" '转化成文本
If Cells(i, j) < 10000 Then '确定哪些数字变色
n = Len(Cells(i, j))
m = 1
Else
m = Len(Int(Cells(i, j) / 10000)) + 1
n = Len(Cells(i, j)) - m + 1
End If
With Cells(i, j).Characters(Start:=m, Length:=n).Font ' 第m位开始变色
.ColorIndex = 15
End With
Next j
Next i
End Sub