☆エコ・RDB 〔6〕データ＋IDの挿入＿SUB

Dim PX As Integer, P1 As Integer, P2 As Integer, CH As Integer, ChX As Integer
Dim ChkDat As Variant, IP As Variant, Rn As Long, Cn As Long
Dim C_0 As Integer, C_1 As Integer, C_2 As Integer, C_1M As Integer
Dim Max0 As Long, Max1 As Integer, Max2 As Integer, TMP2()
Dim Sp0 As Integer, Sp1 As Long, Sp2 As Long, Sp3 As Long
Dim RCpo1 As Long, RCpo2 As Long, RCpo3 As Long
Dim BMax_Cp2 As Long, BMax_Cp3 As Long, BMax_Cp4 As Long
Dim BCut_Cp2 As Long, BCut_Cp3 As Long, BCut_Cp4 As Long

Sub Ins_Dt_ER2(MST As Worksheet, IDX As Worksheet, InsDt As Variant, InsRn As Variant _
       , RwRn As Long, ClRn As Long, MxDt As Long, RCpo0 As Integer, BMax As Integer, BCut As Integer, TMP1())
'
' Ins_Data Macro
' マクロ記録日 : 2008/10/8  ユーザー名 :寺田屋の龍馬
'
'  　一件のマスタデータ＋ＩＤをＲＤＢシートへ挿入〔ＳＵＢ〕

'　　Ｅｃｏ_ＲＤＢ【エコ・ＲＤＢ】 Ver．２.０

    C_0 = 0: C_1 = 1: C_2 = 2: C_1M = 10000: RCpo1 = C_1

    If MxDt = C_0 Then '最初のマスタデータとＩＤの書込み

        MxDt = C_1
        MST.Cells(1, 1) = InsDt
        IDX.Cells(RCpo0 + C_1, 2) = C_1
        IDX.Cells(RCpo0 + C_2, 2) = 10001
        MST.Cells(2, 201) = MxDt
        MST.Cells(2, 202) = MxDt

    Else                'マスタデータとＩＤの書込み（２つめ以降）

    'マスタデータの書込み.........

    MST.Cells(RwRn, ClRn) = InsDt

    'Sub_ID サブＩＤでの挿入するクラスタの検索

        Max1 = IDX.Cells(1, 202)        Max0 = IDX.Cells(2, 202)

        P1 = C_1        P2 = Max1

        PX = Max1 \ C_2 + C_1        CH = C_0: Sp0 = C_1

        If Max1 >= C_2 Then

            While CH <> PX

                IP = TMP1(PX + (Max1 < PX), 1)
                ChkDat = MST.Cells(IP Mod C_1M, IP \ C_1M)
                CH = PX

                If ChkDat > InsDt Then
                    P2 = PX
                Else
                    If ChkDat = InsDt Then
                        If IP > InsRn Then
                            P2 = PX
                        Else
                            P1 = PX + C_1
                        End If
                    Else
                        P1 = PX + C_1
                    End If
                End If
                PX = (P2 - P1) \ C_2 + P1
            Wend
            Sp0 = PX - (PX < C_1)
            Sp0 = PX + (Max1 < PX)
        End If

        Call Worksheet_SelectionChange(IDX.Range(IDX.Range("A" + CStr(RCpo0 + Sp0)).Formula), Rn, Sp1)

        RCpo1 = Rn - C_1

        If Sp0 >= C_2 Then '挿入すべきクラスタを決める

            If MST.Cells(IP Mod C_1M, IP \ C_1M) >= InsDt Then

                Call Worksheet_SelectionChange(IDX.Range(IDX.Range("A" + CStr(RCpo0 + Sp0 - C_1)).Formula), Rn, Sp3)
                RCpo3 = Rn - C_1
                IP = IDX.Cells(RCpo3 + IDX.Cells(RCpo3, Sp3), Sp3)

                If MST.Cells(IP Mod C_1M, IP \ C_1M) > InsDt Or (MST.Cells(IP Mod C_1M, IP \ C_1M) = InsDt And IP >= InsRn) Then

                    Sp0 = Sp0 - C_1: Sp1 = Sp3: RCpo1 = RCpo3
                End If            End If
        End If

    'Main_ID クラスタ内での挿入ポイントの検索

        Max2 = IDX.Cells(RCpo1, Sp1)

        P1 = C_1        P2 = Max2

        PX = Max2 \ C_2 + C_1        CH = C_0: Sp2 = C_1

        While CH <> PX

            ChX = RCpo1 + PX + (Max2 < PX)
            IP = IDX.Cells(ChX, Sp1)            ChkDat = MST.Cells(IP Mod C_1M, IP \ C_1M)
            CH = PX

            If ChkDat > InsDt Then
                P2 = PX
            Else
                If ChkDat = InsDt Then
                    If IP > InsRn Then
                        P2 = PX
                    Else
                        P1 = PX + C_1
                    End If
                Else
                    P1 = PX + C_1
                End If
            End If
            PX = (P2 - P1) \ C_2 + P1
        Wend

    Sp2 = PX
    BCut_Cp2 = RCpo1 + Sp2
    BMax_Cp2 = RCpo1 + Max2

        If Max2 >= Sp2 Then 'インデックスの挿入

            IDX.Range(IDX.Cells(BCut_Cp2 + C_1, Sp1), IDX.Cells(BMax_Cp2 + C_1, Sp1)).Value = _                 IDX.Range(IDX.Cells(BCut_Cp2, Sp1), IDX.Cells(BMax_Cp2, Sp1)).Value

        End If

        IDX.Cells(BCut_Cp2, Sp1) = InsRn

        IDX.Cells(RCpo1, Sp1) = Max2 + C_1

        Max0 = Max0 + C_1
        MxDt = Max0        IDX.Cells(2, 201) = MxDt
        IDX.Cells(2, 202) = Max0

        '１クラスタでのＩＤデータの許容チェック

        If (Max2 + C_1) = BMax Then

            For CH = C_0 To 19 '新しいクラスタを探す

                Sp3 = C_1: Rn = RCpo0 + CH * (BMax + C_2) + C_1                TMP2() = IDX.Range(IDX.Cells(Rn, 1), IDX.Cells(Rn, 202))

                Do                    Sp3 = Sp3 + C_1

                Loop Until TMP2(1, Sp3) = C_0 Or Sp3 > 201'                Loop Until Idx.Cells(Rn, Sp3) = C_0 Or Sp3 > 201

                If Sp3 <= 202 And TMP2(1, Sp3) = C_0 Then CH = 19

            Next

            RCpo2 = Rn
            BCut_Cp3 = RCpo1 + BCut
            BMax_Cp3 = RCpo1 + BMax
            BCut_Cp4 = RCpo2 + BCut
            BMax_Cp4 = RCpo2 + BMax

            '新しいクラスタにＩＤデータを分割

            IDX.Range(IDX.Cells(RCpo2 + C_1, Sp3), IDX.Cells(BMax_Cp4 - BCut + C_1, Sp3)).Value = _                 IDX.Range(IDX.Cells(BCut_Cp3 + C_1, Sp1), IDX.Cells(BMax_Cp3 + C_1, Sp1)).Value

            IDX.Cells(RCpo1, Sp1) = BCut: IDX.Cells(RCpo2, Sp3) = BMax - BCut

            'サブＩＤの更新...

            If Sp0 < Max1 Then

                With IDX
                    .Range(IDX.Cells(RCpo0 + Sp0 + C_1, 1), IDX.Cells(RCpo0 + Max1 + C_2, 1)).Copy
                    .Range(IDX.Cells(RCpo0 + Sp0 + C_2, 1), IDX.Cells(RCpo0 + Max1 + C_2 + C_1 , 1)).PasteSpecial
                End With
            End If

            IDX.Cells(RCpo0 + Sp0 + C_1, 1) = "=R" + CStr(Rn + C_1) + "C" + CStr(Sp3)

            IDX.Cells(1, 202) = Max1 + C_1

            IDX.Range(IDX.Cells(BCut_Cp3 + C_1, Sp1), IDX.Cells(BMax_Cp3 + C_1, Sp1)).Value = _                 IDX.Range(IDX.Cells(BCut_Cp3 + 722, 1), IDX.Cells(BMax_Cp3 + 722, 1)).Value

            TMP1() = IDX.Range(IDX.Cells(RCpo0 + C_1, 1), IDX.Cells(RCpo0 + Max1 + C_1, 1))

         End If    End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range, Rn As Long, Cn As Long)

    Rn = Target.Row

    Cn = Target.Column

End Sub