使用VBA警示异常值。

在非寿险评估工作中，需要看很多三角形。

用肉眼去观测三角形中的异常值非常辛苦。需要一个简单的工具来帮助我们找到异常的数据。

以reported loss ratio的三角形为例，希望找出不同事故年，同一进展年的赔付率的异常波动。

在Excel中的操作逻辑如下：

原始数据（数据为虚拟数据）：

对原始数据相邻行做差，得到LR每事故年的变动值，如下：

以10%为阈值，对大于10%或者小于-10%的区域高亮。基础的想法是条件格式。使用条件格式后效果如下：

这样就突显出了异常值，但是，一个额外的需求是，让原始数据出现同样的高亮。此时无法使用格式刷，因为格式刷中依然是条件格式，刷回原数据，会出现如下情况。

原始数据中，所有数值都高于10%，因此全为红色。

为了实现此额外的需求，写了VBA代码如下：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub suozai()
Dim rg As Range
Set rg = Selection '对选中的三角形区域进行操作，可设置为固定区域
Dim t As Single
t = 0.1 '可以将t设置为单元格的值，为不同的三角形设置不同的阈值
Dim countrows As Integer
Dim countcols As Integer
countrows = rg.Rows.Count
countcols = rg.Columns.Count
'通如下循环，实现对做差三角形中满足高亮的单元格进行高亮
Dim i, j As Integer
For i = 1 To countrows
    For j = 1 To countcols - i + 1
        If rg.Cells(i, j).Value > t Then
            rg.Cells(i, j).Interior.Color = 13551615
        End If
        If rg.Cells(i, j).Value < -t Then
            rg.Cells(i, j).Interior.Color = 13561798
        End If
    Next j
Next i

'接下来的步骤是把格式刷回原始数据,找到原始数据所在地,可以用数格子的方法,也可以用下面的方法.
Dim rg1 As Range
Dim c As String
c = rg.Cells(1, 1).Formula '提取做差三角形中第一个单元格的公式 =A-B
c = Mid(c, 2) '去掉公式中的等号 A-B
d = Split(c, "-")(0) '以减号为分界，分离A，B，并获取A。由于不同类型三角形的公式可能不同，此处可以应用正则表达式进行拓展。学习中
Set rg1 = Range(d).Resize(countrows, countcols) '得到初始数据所在的三角形
rg.Copy
rg1.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False '刷格式
End Sub

使用VBA后的结果

完结撒花。有改进请大家指出。示例文件可以点击在精算后花园论坛下载学习。

许可协议

本文采用 署名-非商业性使用-相同方式共享 4.0 国际 许可协议，转载请注明出处。

分享文章