word表格数据自动校对

anoberts

word表格中一列标准范围，一列检测数值，检测数值需符合标准范围，不符合用红色字体显示，求助用word宏实现，谢谢！

zmj9151

__________________

413191246se

1. Sub AutoCheck_THE_CERTIFICATE_OF_ANALYSIS()
   
2.     Dim r As Range
   
3.     With ActiveDocument.Tables(1)
   
4.         'moisture/water
   
5.         Set r = .Cell(11, 4).Range
   
6.         With r
   
7.             .MoveEnd 1, -1
   
8.             If Len(.Text) = 0 Then
   
9.                 .Text = "NO"
   
10.                 GoSub Fmt
    
11.             Else
    
12.                 If .Text < 5 Or .Text > 7 Then GoSub Fmt
    
13.             End If
    
14.         End With
    
15. 
    
16.         'ash/grey
    
17.         Set r = .Cell(12, 4).Range
    
18.         With r
    
19.             .MoveEnd 1, -1
    
20.             If Len(.Text) = 0 Then
    
21.                 .Text = "NO"
    
22.                 GoSub Fmt
    
23.             Else
    
24.                 If .Text > 5 Then GoSub Fmt
    
25.             End If
    
26.         End With
    
27. 
    
28.         'water-insoluble matter
    
29.         Set r = .Cell(13, 4).Range
    
30.         With r
    
31.             .MoveEnd 1, -1
    
32.             If Len(.Text) = 0 Then
    
33.                 .Text = "NO"
    
34.                 GoSub Fmt
    
35.             Else
    
36.                 If .Text > 1 Then GoSub Fmt
    
37.             End If
    
38.         End With
    
39. 
    
40.         'lead
    
41.         Set r = .Cell(16, 4).Range
    
42.         With r
    
43.             .MoveEnd 1, -1
    
44.             If Len(.Text) = 0 Then
    
45.                 .Text = "NO"
    
46.                 GoSub Fmt
    
47.             Else
    
48.                 If .Text > 3 Then GoSub Fmt
    
49.             End If
    
50.         End With
    
51. 
    
52.         'arsenic
    
53.         Set r = .Cell(17, 4).Range
    
54.         With r
    
55.             .MoveEnd 1, -1
    
56.             If Len(.Text) = 0 Then
    
57.                 .Text = "NO"
    
58.                 GoSub Fmt
    
59.             Else
    
60.                 If .Text > 3 Then GoSub Fmt
    
61.             End If
    
62.         End With
    
63. 
    
64.         'total plate count
    
65.         Set r = .Cell(19, 4).Range
    
66.         With r
    
67.             .MoveEnd 1, -1
    
68.             If Len(.Text) = 0 Then
    
69.                 .Text = "NO"
    
70.                 GoSub Fmt
    
71.             Else
    
72.                 If .Text > 5000 Then GoSub Fmt
    
73.             End If
    
74.         End With
    
75. 
    
76.         'mold
    
77.         Set r = .Cell(20, 4).Range
    
78.         With r
    
79.             .MoveEnd 1, -1
    
80.             If Len(.Text) = 0 Then
    
81.                 .Text = "NO"
    
82.                 GoSub Fmt
    
83.             Else
    
84.                 If .Text > 100 Then GoSub Fmt
    
85.             End If
    
86.         End With
    
87.     End With
    
88.     Exit Sub
    
89. 
    
90. Fmt:
    
91.     With r.Font
    
92.         .NameAscii = "Impact"
    
93.         .Size = 16
    
94.         .ColorIndex = wdRed
    
95.         .Underline = wdUnderlineSingle
    
96.     End With
    
97.     Return
    
98. End Sub

复制代码

anoberts

谢谢EH侠圣

anoberts

谢谢太匆匆