使用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后的结果

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

交流区

交流请移步至精算后花园论坛 https://actuaryunion.com