二つのﾎﾞﾃﾞｨ/形状ｾｯﾄを比較して、差分を抽出する2

こちらの続きです。
http://kantoku.hatenablog.com/entry/2016/11/24/173743
http://kantoku.hatenablog.com/entry/2017/07/19/190425

原因を突き止め切れていないのですが、結果が総当りと
一致するようになりました。

まずは、本ﾏｸﾛのｴﾝﾄﾘｰﾎﾟｲﾝﾄを持つ標準ﾓｼﾞｭｰﾙ "GetChangeArea.bas"
です。

'vba GetChangeArea.bas_ver0.0.2  using-'KCL0.0.10'
'2つのﾎﾞﾃﾞｨ/形状ｾｯﾄの異なる面を抽出
Option Explicit

'*** 設定値 ***
Const COGTOLERANCE = 0.001                  '同一判断重心距離
Const AREATOLERANCE = 0.01                  '同一判断面積

Const RESULT_COLOR = "255, 0, 0"            '抽出後色
Const RESULT_WIDTH = 4                      '抽出後幅
'**************

Const CogTolSqr = COGTOLERANCE * COGTOLERANCE

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute(Array("PartDocument", "ProductDocument")) Then Exit Sub
    
    '対象ﾎﾞﾃﾞｨ選択
    Dim Msg$: Msg = "ﾁｪｯｸするﾎﾞﾃﾞｨ/形状ｾｯﾄを選択して下さい : ESCｷｰ 終了"
    Dim TgtBody As AnyObject: Set TgtBody = KCL.SelectItem(Msg, "Body,HybridBody")
    If KCL.IsNothing(TgtBody) Then Exit Sub
    Dim TgtCount&: TgtCount = SearchTopoFaces(TgtBody)
    If TgtCount < 1 Then
        MsgBox TgtBody.Name + " に面が有りません!"
        Exit Sub
    End If
    
    '参照ﾎﾞﾃﾞｨ選択
    Msg = "比較するﾎﾞﾃﾞｨ/形状ｾｯﾄを選択して下さい : ESCｷｰ 終了"
    Dim RefBody As AnyObject: Set RefBody = KCL.SelectItem(Msg, "Body,HybridBody")
    If KCL.IsNothing(RefBody) Then Exit Sub
    Dim RefCount&: RefCount = SearchTopoFaces(RefBody)
    If RefCount < 1 Then
        MsgBox RefBody.Name + " に面が有りません!"
        Exit Sub
    End If
    
    '確認
    Msg = TgtBody.Name + "(" + CStr(TgtCount) + "枚)の変更箇所を" + vbNewLine + _
          RefBody.Name + "(" + CStr(RefCount) + "枚)を元に" + vbNewLine + _
          "確認しますか?"
    If MsgBox(Msg, vbYesNo) = vbNo Then Exit Sub
    
    KCL.SW_Start
    
    '対象ﾎﾞﾃﾞｨ ﾘﾌｧﾚﾝｽ取得
    Dim TgtRefs As Variant: TgtRefs = GetTopoFacesRef(TgtBody)
    If IsEmpty(TgtRefs) Then Exit Sub
    
    '対象ﾎﾞﾃﾞｨ ﾄﾎﾟﾛｼﾞ情報取得
    Dim TgtGeos As Variant:  TgtGeos = GetGeoInfo(TgtBody, TgtRefs)
    
    '参照ﾎﾞﾃﾞｨ ﾘﾌｧﾚﾝｽ取得
    Dim RefRefs As Variant: RefRefs = GetTopoFacesRef(RefBody)
    If IsEmpty(RefRefs) Then Exit Sub
    
    '参照ﾎﾞﾃﾞｨ ﾄﾎﾟﾛｼﾞ情報取得
    Dim RefGeos As Variant:  RefGeos = GetGeoInfo(RefBody, RefRefs)
    
    '差分ｲﾝﾃﾞｯｸｽ取得
    Dim DifIdxs As Variant: DifIdxs = GetDifference(TgtGeos, RefGeos)
    If IsEmpty(DifIdxs) Then
        MsgBox "'" + TgtBody.Name + "' と '" + RefBody.Name + "' " + vbNewLine + _
               "の違いは見つかりませんでした"
        Exit Sub
    End If
    
    '差分面作成
    Call ExtractFace(TgtBody, TgtRefs, DifIdxs, TgtBody.Name & "-" & RefBody.Name)
    
    '終了
    Debug.Print CStr(KCL.SW_GetTime) + "秒"
    MsgBox CStr(UBound(DifIdxs) + 1) + "枚分の違いを作成しました"
End Sub

'差分面作成
Private Sub ExtractFace(ByVal ParentOj As AnyObject, ByRef Refs As Variant, ByVal Idx As Variant, ByVal HBName As String)
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(ParentOj, "PartDocument")
    Dim Pt As Part: Set Pt = Doc.Part
    
    CATIA.HSOSynchronized = False
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    
    Dim Ref As Reference
    Set Ref = Pt.CreateReferenceFromBRepName(KCL.GetBrepName(Refs(Idx(0)).DisplayName), Refs(Idx(0)).Parent)
    
    Dim Exts As HybridShapeExtractMulti: Set Exts = Fact.AddNewExtractMulti(Ref)
    Dim i&, j&
    For i = 0 To UBound(Idx)
        Set Ref = Pt.CreateReferenceFromBRepName(KCL.GetBrepName(Refs(Idx(i)).DisplayName), Refs(Idx(i)).Parent)
        Exts.AddConstraintTolerant Ref, 3, False, False, 0.01, 0.5, 0.98, i + 1
    Next
    Pt.UpdateObject Exts
    Dim Hb As HybridBody: Set Hb = Doc.Part.HybridBodies.Add()
    Hb.Name = HBName & "_Change_Area"
    Set Ref = Pt.CreateReferenceFromObject(Exts)
    Dim Exp As HybridShapeSurfaceExplicit: Set Exp = Fact.AddNewSurfaceDatum(Ref)
    Hb.AppendHybridShape Exp
    Call SetGraphicProperty(Doc.Selection, Exp)
    Pt.UpdateObject Exp
    Fact.DeleteObjectForDatum Ref
    CATIA.HSOSynchronized = True
End Sub

'色等設定
Private Sub SetGraphicProperty(ByRef Sel As Selection, ByVal Face As Variant)
    Dim VPS As VisPropertySet: Set VPS = Sel.VisProperties
    Dim AryRGB As Variant
    AryRGB = Split(RESULT_COLOR, ",")
    
    CATIA.HSOSynchronized = False
    Sel.Clear
    Sel.Add Face
    VPS.SetRealColor AryRGB(0), AryRGB(1), AryRGB(2), 1
    VPS.SetRealWidth RESULT_WIDTH, 1
    Sel.Clear
    CATIA.HSOSynchronized = True
End Sub

'差分検索 return-異なるIdx
Private Function GetDifference(ByRef TgtGeos As Variant, ByRef RefGeos As Variant) As Variant
    Dim Cnt&: Cnt = UBound(TgtGeos) + UBound(RefGeos)
    Dim UnHit() As Variant: ReDim UnHit(Cnt)
    Dim UnHitCnt&: UnHitCnt = -1
    Dim i&, j&, k&, HitFg As Boolean
    
    Dim CombAry As Variant
    CombAry = GetCombinationAry(TgtGeos, RefGeos)
    
    For i = 0 To UBound(CombAry)
        For j = 0 To UBound(CombAry(i)(0))
            HitFg = False
            For k = 0 To UBound(CombAry(i)(1))
                If IsGeoEqual(TgtGeos(CombAry(i)(0)(j)), RefGeos(CombAry(i)(1)(k))) Then
                    HitFg = True
                    Exit For
                End If
            Next
            If HitFg = False Then
                UnHitCnt = UnHitCnt + 1
                UnHit(UnHitCnt) = CombAry(i)(0)(j)
            End If
        Next
    Next
    
    If UnHitCnt < 0 Then Exit Function
    ReDim Preserve UnHit(UnHitCnt)
    GetDifference = UnHit
End Function

'組み合わせ-8分木ﾗｲﾌﾞﾗﾘ利用
Private Function GetCombinationAry(ByVal Ary1 As Variant, ByVal Ary2 As Variant) As Variant ' Collection
    Dim Lst As Collection: Set Lst = ToList(Ary1, Ary2)
    Dim SplitCnt As Long: SplitCnt = UBound(Ary1) + 1
    
    Dim OctLst As Collection
    Set OctLst = GetChangeArea_Oct.GetLinerOctreeList(Lst, COGTOLERANCE, 50)
    
    Dim CombAry() As Variant: ReDim CombAry(OctLst.Count - 1)
    Dim Space As Collection, Idx As Variant
    Dim Lst1 As Collection, Lst2 As Collection
    Dim Cnt As Long: Cnt = -1
    For Each Space In OctLst
        Set Lst1 = New Collection
        Set Lst2 = New Collection
        For Each Idx In Space
            If Idx < SplitCnt + 1 Then
                Lst1.Add Idx - 1
            Else
                Lst2.Add Idx - SplitCnt - 1
            End If
        Next
        Cnt = Cnt + 1
        CombAry(Cnt) = Array(ToAry(Lst1), ToAry(Lst2))
    Next
    GetCombinationAry = CombAry
End Function

'ｺﾚｸｼｮﾝ配列化
Private Function ToAry(ByVal Lst As Collection) As Variant
    If Lst.Count < 1 Then
        ToAry = Array()
        Exit Function
    End If
    Dim Ary() As Variant: ReDim Ary(Lst.Count - 1)
    Dim i As Long
    
    For i = 1 To Lst.Count
        Ary(i - 1) = Lst.Item(i)
    Next
    ToAry = Ary
End Function

'二つの配列を連結しｺﾚｸｼｮﾝ化
Private Function ToList(ByVal Ary1 As Variant, ByVal Ary2 As Variant) As Collection
    Dim Lst As Collection: Set Lst = New Collection
    Dim i As Long
    
    For i = 0 To UBound(Ary1)
        Lst.Add Ary1(i)
    Next
    For i = 0 To UBound(Ary2)
        Lst.Add Ary2(i)
    Next
    Set ToList = Lst
End Function

'Geo一致
Private Function IsGeoEqual(ByVal P1 As Variant, ByVal P2 As Variant) As Boolean
    IsGeoEqual = False
    If IsCogEqual(P1, P2) And IsAreaEqual(P1, P2) Then IsGeoEqual = True
End Function

'COG一致
Private Function IsCogEqual(ByVal P1 As Variant, ByVal P2 As Variant) As Boolean
    IsCogEqual = False
    If Abs((P2(0) - P1(0)) * (P2(0) - P1(0)) + _
           (P2(1) - P1(1)) * (P2(1) - P1(1)) + _
           (P2(2) - P1(2)) * (P2(2) - P1(2))) < CogTolSqr Then
        IsCogEqual = True
    End If
End Function

'Area一致
Private Function IsAreaEqual(ByVal P1 As Variant, ByVal P2 As Variant) As Boolean
    IsAreaEqual = False
    If Abs(P2(3) - P1(3)) < AREATOLERANCE Then
        IsAreaEqual = True
    End If
End Function

'CogとAreaの取得
'0-CogX 1-CogY 2-CogZ 3-Area
Private Function GetGeoInfo(ByVal ParentOj As AnyObject, ByRef Refs As Variant) As Variant
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(ParentOj, "PartDocument")
    Dim SPA As SPAWorkbench: Set SPA = Doc.GetWorkbench("SPAWorkbench")
    Dim Infos() As Variant: ReDim Infos(UBound(Refs))
    Dim Cog(3) As Variant, i&, Mes As Variant 'Measurable
    
    For i = 0 To UBound(Infos)
        Set Mes = SPA.GetMeasurable(Refs(i))
        Mes.GetCOG Cog
        Cog(3) = Mes.Area
        Infos(i) = Cog
    Next
    GetGeoInfo = Infos
End Function

'topologyのFaceのReference取得
Private Function GetTopoFacesRef(ByVal AnyOj As AnyObject) As Variant
    If SearchTopoFaces(AnyOj) < 1 Then Exit Function
    
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(AnyOj, "PartDocument")
    Dim Sel As Selection: Set Sel = Doc.Selection
    Dim Refs() As Reference: ReDim Refs(Sel.Count2 - 1)
    Dim i&
    For i = 0 To Sel.Count2 - 1
        Set Refs(i) = Sel.Item(i + 1).Reference
    Next
    GetTopoFacesRef = Refs
End Function

'topologyのFaceの検索
Private Function SearchTopoFaces(ByVal AnyOj As AnyObject) As Long
    Dim Sel As Selection: Set Sel = KCL.GetParent_Of_T(AnyOj, "PartDocument").Selection
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        .Add AnyOj
        .Search "Topology.CGMFace,sel"
    End With
    CATIA.HSOSynchronized = True
    SearchTopoFaces = Sel.Count2
End Function

続いて、我流8分木ﾗｲﾌﾞﾗﾘ標準ﾓｼﾞｭｰﾙ "GetChangeArea_Oct.bas" です。

'vba GetChangeArea_Oct.bas Ver0.0.1  using-'KCL0.0.10'
'ﾓｰﾄﾝ順序を利用した8分木空間分割ﾗｲﾌﾞﾗﾘ
'GetChangeAreaﾏｸﾛ専用です

Option Explicit

Private Const CLINER8TREEMANAGER_MAXLEVEL = 7   '有効空間分割最大ﾚﾍﾞﾙ

Private m_Level&                                '分割ﾚﾍﾞﾙ
Private m_Tolerance#                            '一致ﾄﾚﾗﾝｽ
Private m_MaxCount&                             '同一空間内最大数(目安)
Private m_AxisCount&                            '空間分割時の各軸の最大数
Private m_MinPos                                '空間最小座標
Private m_Unit                                  '空間単位ｻｲｽﾞ
Private m_ToleranceRatio                        '空間単位ｻｲｽﾞに対してのﾄﾚﾗﾝｽ比率
Private m_CellCount&()                          'ﾚﾍﾞﾙ毎の空間数

'*** Octree ***
'http://marupeke296.com/COL_3D_No15_Octree.html

'線形8分木ﾘｽﾄ取得
''' @param :Pnts-Collection(array(Double))-座標値郡
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @param :MaxCount-long-同一空間内最大数(目安)
''' @return:Collection(Collection(long))-空間別点Idx郡
Function GetLinerOctreeList(ByVal Pnts As Collection, ByVal Tolerance#, ByVal MAXCOUNT&)
    Set GetLinerOctreeList = Nothing
    
    '座標値郡のIdxList作成
    Dim PntIdxList As Collection: Set PntIdxList = InitRangeList(Pnts.Count)
    
    '空間内最大数以下の場合、そのまま返す
    Dim DecidedList As Collection: Set DecidedList = New Collection
    If Pnts.Count < MAXCOUNT Then
        Call DecidedList.Add(PntIdxList)
        GoTo FuncEnd
    End If
    
    '初期設定
    If Not SetStart(Tolerance, MAXCOUNT) Then
        MsgBox "設定値が不正です"
        Exit Function
    End If
    
    'IdxListをﾙｰﾄ空間として登録
    Dim CheckList As Collection: Set CheckList = New Collection
    Call CheckList.Add(PntIdxList)
    
    'ﾚﾍﾞﾙの応じたIdx用配列
    Dim SpeceEnum, TempList As Collection, ReCheckList As Collection
    Dim Space, TempSpace, SpaAry, i&, Idx
    Do
        Set ReCheckList = New Collection
        '配置
        For Each Space In CheckList
            If Not SetSpaceInfo(Pnts, Space) Then '空間が小さすぎる
                Call DecidedList.Add(Space)
                GoTo continue
            End If
            
            SpeceEnum = InitRangeAry(m_CellCount(m_Level), -1)
            Set TempList = New Collection
            
            For Each Idx In Space
                SpaAry = GetMortonNum(Pnts(Idx))
                For i = 0 To UBound(SpaAry)
                    If SpeceEnum(SpaAry(i)) < 0 Then
                        Call TempList.Add(InitSpace())
                        SpeceEnum(SpaAry(i)) = TempList.Count
                    End If
                    Call TempList.Item(SpeceEnum(SpaAry(i))).Add(Idx)
                Next
            Next
            
            '空間毎の数が多いものを再配置
            For Each TempSpace In TempList
                Select Case True
                    Case TempSpace.Count < 2
                        Call DecidedList.Add(TempSpace)
                    Case TempSpace.Count > m_MaxCount
                        Call ReCheckList.Add(TempSpace)
                    Case Else
                        Call DecidedList.Add(TempSpace)
                End Select
            Next
continue:
        Next
        If ReCheckList.Count < 1 Then Exit Do
        Set CheckList = ReCheckList
    Loop
    
FuncEnd:
    Call Q_ISort_List(DecidedList)
    Set GetLinerOctreeList = DecidedList
    Set PntIdxList = Nothing
    Set DecidedList = Nothing
    Set CheckList = Nothing
    Set ReCheckList = Nothing
    Set TempList = Nothing
    ReDim SpeceEnum(0)
End Function

'空のｺﾚｸｼｮﾝ
Private Function InitSpace() As Collection
    Set InitSpace = New Collection
End Function

'線形8分木準備
''' @param :Level-long-分割ﾚﾍﾞﾙ
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @param :MaxCount-long-同一空間内最大数(目安)
''' @return:Boolean
Private Function SetStart(ByVal Tolerance#, ByVal MAXCOUNT&) As Boolean
    SetStart = False
    If Tolerance <= 0 Then Exit Function
    
    m_Tolerance = Tolerance
    m_MaxCount = MAXCOUNT
    m_ToleranceRatio = InitRangeAry(2, 0)
    
    ReDim m_CellCount(CLINER8TREEMANAGER_MAXLEVEL + 1)
    m_CellCount(0) = 1
    Dim i&
    For i = 1 To UBound(m_CellCount)
        m_CellCount(i) = m_CellCount(i - 1) * 8
    Next
    SetStart = True
End Function

'空間ｻｲｽﾞとﾄﾚﾗﾝｽからﾚﾍﾞﾙ算出し設定
Private Function SetLevel(ByVal W) As Boolean
    SetLevel = False
    Dim Min#: Min = 1.79769313486231E+308
    Dim i&
    For i = 0 To 2
         If Min > W(i) Then Min = W(i)
    Next
    Dim TmpLv&: TmpLv = Fix(Log_n((Min / (m_Tolerance * 2 + 0.002)), 2))
    If TmpLv > CLINER8TREEMANAGER_MAXLEVEL Then
        m_Level = CLINER8TREEMANAGER_MAXLEVEL
    Else
        m_Level = TmpLv
    End If
    
    If m_Level < 1 Then Exit Function
    m_AxisCount = sl(1, m_Level)
    SetLevel = True
End Function

'空間情報設定
''' @param :Pnts-Collection(array(Double))-座標値郡
''' @param :Idxs-Collection(long)-座標値郡Idx
''' @return:Boolean
Private Function SetSpaceInfo(ByVal Pnts, ByVal idxs As Collection) As Boolean
    SetSpaceInfo = False
    Dim SpSize: SpSize = GetSpaceSize_Idx(Pnts, idxs)
    m_MinPos = AryAdd(SpSize(0), m_Tolerance * -2)
    Dim W: W = ArySub(AryAdd(SpSize(1), m_Tolerance * 2 + 0.002), m_MinPos)
    If Not SetLevel(W) Then Exit Function
    m_Unit = AryDiv(W, m_AxisCount)
    
    Dim i&
    For i = 0 To 2
        m_ToleranceRatio(i) = m_ToleranceRatio(i) / m_Unit(i)
    Next
    SetSpaceInfo = True
End Function

'座標→最小ﾚﾍﾞﾙ空間番号郡取得
''' @param :Pos-array(Double)-座標値
''' @return:array(Long)
Private Function GetMortonNum(ByVal pos As Variant) As Variant
    Dim Ratio#(2), Inte&(2), Dec#(2)
    Dim i&
    For i = 0 To 2
        Ratio(i) = (pos(i) - m_MinPos(i)) / m_Unit(i)
        Inte(i) = Fix(Ratio(i))
        Dec(i) = Ratio(i) - Inte(i)
    Next
    
    Dim Axis(2) As Variant
    Dim AxisNums As Collection
    For i = 0 To 2
        Set AxisNums = New Collection
        AxisNums.Add Inte(i)
        If Dec(i) <= m_ToleranceRatio(i) And Inte(i) > 0 Then AxisNums.Add Inte(i) - 1
        If 1# - Dec(i) <= m_ToleranceRatio(i) And Inte(i) < m_AxisCount - 1 Then AxisNums.Add Inte(i) + 1
        Set Axis(i) = AxisNums
    Next
    
    Dim x, y, z
    Dim SpaNo(): ReDim SpaNo(Axis(0).Count * Axis(1).Count * Axis(2).Count)
    Dim Cnt&: Cnt = -1
    For Each x In Axis(0)
        For Each y In Axis(1)
            For Each z In Axis(2)
                Cnt = Cnt + 1
                SpaNo(Cnt) = Get3DMortonNumber(x, y, z)
                If SpaNo(Cnt) < 0 And SpaNo(Cnt) >= m_CellCount(m_Level) Then Cnt = Cnt - 1
    Next: Next: Next
    ReDim Preserve SpaNo(Cnt)
    GetMortonNum = SpaNo
End Function

'ビット分割関数
''' @param :n-long
''' @return:long
Private Function BitSeparateFor3D(ByVal n&) As Long
    Dim s As Long: s = n
    s = (s Or sl(s, 8)) And &HF00F
    s = (s Or sl(s, 4)) And &HC30C3
    s = (s Or sl(s, 2)) And &H249249
    BitSeparateFor3D = s
End Function

'8分木モートン順序算出関数
''' @param :x-long
''' @param :y-long
''' @param :z-long
''' @return:long
Private Function Get3DMortonNumber(ByVal x&, ByVal y&, ByVal z&) As Long
   Get3DMortonNumber = BitSeparateFor3D(x) Or _
                       sl(BitSeparateFor3D(y), 1) Or _
                       sl(BitSeparateFor3D(z), 2)
End Function

'座標値郡から空間ｻｲｽﾞ取得
''' @param :EndPnts-Collection(array(Double))-座標値郡
''' @return:array(array(Double))-0:最小値 1:最大値
Private Function GetSpaceSize_Idx(ByVal EndPnts As Collection, ByVal IdxList As Collection) As Variant
    Dim Min: Min = InitRangeAry(2, 1.79769313486231E+308)
    Dim Max: Max = InitRangeAry(2, -1.79769313486231E+308)
    
    Dim Idx, i&
    For Each Idx In IdxList
        For i = 0 To 2
            If Min(i) > EndPnts.Item(Idx)(i) Then Min(i) = EndPnts.Item(Idx)(i)
            If Max(i) < EndPnts.Item(Idx)(i) Then Max(i) = EndPnts.Item(Idx)(i)
        Next
    Next
    GetSpaceSize_Idx = Array(Min, Max)
End Function

'*** BitShift ***
'http://www.geocities.co.jp/SiliconValley/4334/unibon/asp/bitshift2.html
' 左シフト
Private Function sl(ByVal x&, ByVal n&) As Long
    If n = 0 Then
        sl = x
    Else
        Dim k: k = CLng(2 ^ (32 - n - 1))
        Dim D: D = x And (k - 1)
        Dim c: c = D * CLng(2 ^ n)
        If x And k Then c = c Or &H80000000
        sl = c
    End If
End Function

'*** VBA不足関数 ***
'配列同士の引き算-細かいチェック無し
Private Function ArySub(ByVal a, ByVal b) As Variant
    ArySub = Array(a(0) - b(0), a(1) - b(1), a(2) - b(2))
End Function

'配列と実数の足し算-細かいチェック無し
Private Function AryAdd(ByVal a, ByVal b#) As Variant
    AryAdd = Array(a(0) + b, a(1) + b, a(2) + b)
End Function

'配列と実数の割り算-細かいチェック無し
Private Function AryDiv(ByVal a, ByVal b#) As Variant
    AryDiv = Array(a(0) / b, a(1) / b, a(2) / b)
End Function

'初期化済み配列生成 - ｵﾌﾞｼﾞｪｸﾄNG
Private Function InitRangeAry(ByVal Count&, ByVal Value As Variant)
    Dim Ary() As Variant: ReDim Ary(Count)
    Dim i&
        For i = 0 To Count
            Ary(i) = Value
        Next
    InitRangeAry = Ary
End Function

'初期化済みｺﾚｸｼｮﾝ生成
Private Function InitRangeList(ByVal Count&) As Collection
    Dim List As Collection: Set List = New Collection
    Dim i&
    For i = 1 To Count
        List.Add i
    Next
    Set InitRangeList = List
End Function

'ｺﾚｸｼｮﾝｶｳﾝﾀによるｸｲｯｸｿｰﾄ　非再帰版
'https://foolexp.wordpress.com/2011/10/29/%E3%82%AF%E3%82%A4%E3%83%83%E3%82%AF%E3%82%BD%E3%83%BC%E3%83%88%E3%81%A8%E6%8C%BF%E5%85%A5%E3%82%BD%E3%83%BC%E3%83%88%E3%81%AE%E3%83%8F%E3%82%A4%E3%83%96%E3%83%AA%E3%83%83%E3%83%89/
'http://ufcpp.net/study/algorithm/sort_quick.html
'http://thom.hateblo.jp/entry/2015/11/29/212934
Private Sub Q_ISort_List(ByRef List As Collection)
    Dim THREASHOLD&: THREASHOLD = 64
    Dim Stack As Collection: Set Stack = New Collection
    Stack.Add 1, CStr(Stack.Count + 1)
    Stack.Add List.Count, CStr(Stack.Count + 1)
    
    Dim Pivot, Temp1, Temp2
    Dim LeftIdx&, RightIdx&, i&, j&
    Do While Stack.Count > 0
        LeftIdx = Stack(CStr(Stack.Count - 1))
        RightIdx = Stack(CStr(Stack.Count))
        Stack.Remove Stack.Count
        Stack.Remove Stack.Count
        'クイックソート
        If LeftIdx < RightIdx Then
            Set Pivot = List((LeftIdx + RightIdx) / 2)
            i = LeftIdx
            j = RightIdx
            
            Do While i <= j
                Do While List(i).Count < Pivot.Count
                    i = i + 1
                Loop
                Do While List(j).Count > Pivot.Count
                    j = j - 1
                Loop
                If i <= j Then
                    Set Temp1 = List(i)
                    Set Temp2 = List(j)
                    List.Add Temp1, After:=j
                    List.Remove j
                    List.Add Temp2, After:=i
                    List.Remove i
                    i = i + 1
                    j = j - 1
                End If
            Loop
            
            If RightIdx - i >= 0 Then
                If RightIdx - i <= THREASHOLD Then
                    ComboInsertionSort List, i, RightIdx
                Else
                    Stack.Add i, CStr(Stack.Count + 1)
                    Stack.Add RightIdx, CStr(Stack.Count + 1)
                End If
            End If
            
            If j - LeftIdx >= 0 Then
                If j - LeftIdx <= THREASHOLD Then
                    ComboInsertionSort List, LeftIdx, j
                Else
                    Stack.Add LeftIdx, CStr(Stack.Count + 1)
                    Stack.Add j, CStr(Stack.Count + 1)
                End If
            End If
        End If
    Loop
End Sub

'InsertSort
Private Sub ComboInsertionSort(ByRef List, ByVal MinIdx&, ByVal MaxIdx&)
    Dim Temp1, Temp2
    Dim i&, j&: j = 1
    For j = MinIdx To MaxIdx
        i = j - 1
        Do While i >= 1
            If List(i + 1).Count < List(i).Count Then
                Set Temp1 = List(i + 1)
                Set Temp2 = List(i)
                List.Add Temp2, After:=i + 1
                List.Remove i + 1
                List.Add Temp1, After:=i
                List.Remove i
            Else
                Exit Do
            End If
            i = i - 1
        Loop
    Next
End Sub

'nを底とする対数
Private Function Log_n(x, n)
    Log_n = Log(x) / Log(n)
End Function

以上の2つとKCLを、同一ﾌﾟﾛｼﾞｪｸﾄ内としておいて下さい。

ﾃｽﾄ結果です。

〇2884枚-2866枚　抽出面178枚
ver0.0.1:39.825秒
ver0.0.2:13.909秒

〇2871枚-2199枚　抽出面1388枚
ver0.0.1:46.117秒
ver0.0.2:33.396秒

8分木の効果は出ていますが、もう少し効果が出るかと
期待していたのですが･･･。