IBNR计算(Chain Ladder方法) 实用VBA -- 选择 左上三角 / 右下三角范围

[Mengkelyu]

IBNR计算的过程中，我们常常遇到的一个问题是左上的三角和右下的三角公式不同。
这个时候如果我们想要粘贴公式，就需要手动选择一个三角形的范围并粘贴。

手动选择三角形的范围这个工作，我们可以通过宏来实现。

这个宏可以实现如下功能，以左上三角形为例，当选择一个正方形或者矩形区域时：

运行代码后可以得到一个如下的上三角区域。

当然，如果选择的是一个矩形

仍然可以运行代码得到一个不完整的上三角形

[Mengkelyu]

代码的实现思路是横向把每个小矩形加入到三角形之中。

Sub LTTriangle() 

’row和col用来定义选择的矩形的长和宽

Dim row As Integer
Dim col As Integer

row = Selection.Rows.Count
col = Selection.Columns.Count

'rg是一个工具范围，用来做reference

Dim rg As Range
'targetRg用来储存我们最后要得到的三角形范围

Dim targetRg As Range

Dim i As Integer

'初始化
'Selection代表选择的范围；rg是选择的范围的左第一列

Set rg = Selection.Resize(row, 1)
Set targetRg = Selection.Resize(row, 1)

'逐渐把每个小矩形加入到目标三角形

For i = 1 To col - 1

   If row - i > 0 Then Set targetRg = Union(targetRg, rg.Offset(0, i).Resize(row - i, 1))
    
Next i

'选择已经定义好的范围

targetRg.Select

End Sub

[Mengkelyu]

留下一个题目：如何选择右下的三角形呢？欢迎大家提供答案~ 示例文件如下供大家参考~
Triangle example.zip

[Mengkelyu]

可以利用GetSubtractRng这个计算差集的函数来得到右下角三角形的范围

Function GetSubtractRng(r1 As Range, r2 As Range)
    Dim r As Range, r3 As Range
    For Each r In r1
        If Intersect(r, r2) Is Nothing Then
            If r3 Is Nothing Then
                Set r3 = r
            Else
                Set r3 = Union(r, r3)
            End If
        End If
    Next
    Set GetSubtractRng = r3
End Function


Sub RBTriangle()


Dim row As Integer
Dim col As Integer

row = Selection.Rows.Count
col = Selection.Columns.Count


Dim rg As Range

Dim targetRg As Range

Dim i As Integer

Set rg = Selection.Resize(row, 1)
Set targetRg = Selection.Resize(row, 1)


For i = 1 To col - 1

   If row - i > 0 Then Set targetRg = Union(targetRg, rg.Offset(0, i).Resize(row - i, 1))
    
Next i

Set targetRg = GetSubtractRng(Selection, targetRg)

targetRg.Select

End Sub