☆エコ・RDB 〔8〕データ＋IDの削除＿SUB

Dim PX As Integer, P1 As Integer, P2 As Integer, CH As Integer, ChX As Integer
Dim ChkDat As Variant, DP As Variant, Rn As Long, Cn As Long
Dim Max0 As Long, Max1 As Integer, Max2 As Integer, Max3 As Integer, Max4 As Integer
Dim C_0 As Integer, C_1 As Integer, C_2 As Integer, C_1M As Integer

Dim Sp0 As Integer, Sp1 As Long, Sp2 As Long, Sp3 As Long, Sp4 As Long, SpR As Long
Dim RCpo1 As Long, RCpo2 As Long, RCpo3 As Long, RCpo4 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 Del_Dt_ER2(MST As Worksheet, IDX As Worksheet, DelDt As Variant, DelRn As Variant, Cl As Variant _
             , MxDt As Long, RCpo0 As Integer, BMax As Integer, BCut As Integer, TMP1())
'
' Del_Data Macro
' マクロ記録日 : 2008/10/8  ユーザー名 :寺田屋の龍馬
'
'  　一件のマスタデータ＋ＩＤをＲＤＢシートより削除〔ＳＵＢ〕

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

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

    '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

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

                If ChkDat > DelDt Then
                    P2 = PX
                Else
                    If ChkDat = DelDt Then
                        If DP > DelRn 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(DP Mod C_1M, DP \ C_1M) >= DelDt Then

                Call Worksheet_SelectionChange(IDX.Range(IDX.Range("A" + CStr(RCpo0 + Sp0 - C_1)).Formula), Rn, Sp3)
                RCpo3 = Rn - C_1: DP = IDX.Cells(RCpo3 + IDX.Cells(RCpo3, Sp3), Sp3)
      
                If MST.Cells(DP Mod C_1M, DP \ C_1M) > DelDt Or (MST.Cells(DP Mod C_1M, DP \ C_1M) = _
                    DelDt And DP >= DelRn) Then
                    Sp0 = Sp0 - C_1: Sp1 = Sp3: RCpo1 = RCpo3
                End If
            End If
        End If
    RCpo2 = RCpo1

    '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)
            DP = IDX.Cells(ChX, Sp1)
            ChkDat = MST.Cells(DP Mod C_1M, DP \ C_1M)
            CH = PX

            If ChkDat > DelDt Then
                P2 = PX
            Else
                If ChkDat = DelDt Then
                    If DP > DelRn 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 + (PX > C_1)
    ChX = RCpo1 + Sp2 + (Max2 < Sp2)
    DP = IDX.Cells(ChX, Sp1)
    ChkDat = MST.Cells(DP Mod C_1M, DP \ C_1M)
    BCut_Cp2 = RCpo2 + Sp2
    BMax_Cp2 = RCpo2 + Max2

        Max3 = C_0: Max4 = C_0

        '削除するマスタデータとレコード番号のチェック
        If Max2 >= Sp2 And (ChkDat = DelDt And DP = DelRn) Then

            'インデックスの削除
            IDX.Range(IDX.Cells(BCut_Cp2, Sp1), IDX.Cells(BMax_Cp2, Sp1)).Value = _
                IDX.Range(IDX.Cells(BCut_Cp2 + C_1, Sp1), IDX.Cells(BMax_Cp2 + C_1, Sp1)).Value

            Rn = DelRn Mod C_1M
            Cn = DelRn \ C_1M
            MST.Cells(Rn, Cn) = Cl 'マスタデータの削除

            Max2 = Max2 - C_1
            IDX.Cells(RCpo2, Sp1) = Max2

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

            If Sp2 = C_1 Then
               
                TMP1() = IDX.Range(IDX.Cells(RCpo0 + C_1, 1), IDX.Cells(RCpo0 + Max1 + C_1, 1))
            End If

        End If

        If Max2 < BMax * 0.4 Then '前後のクラスタのＩＤ数をチェック

            ChX = C_0
            If Sp0 > C_1 Then
                Call Worksheet_SelectionChange(IDX.Range(IDX.Range("A" + CStr(RCpo0 + Sp0 - C_1)).Formula), Rn, Sp3)
                RCpo3 = Rn - C_1: Max3 = IDX.Cells(RCpo3, Sp3)
            End If

            If Sp0 < Max1 Then
                Call Worksheet_SelectionChange(IDX.Range(IDX.Range("A" + CStr(RCpo0 + Sp0 + C_1)).Formula), Rn, Sp4)
                RCpo4 = Rn - C_1: Max4 = IDX.Cells(RCpo4, Sp4)
            End If

            If Max3 < Max4 Or Max4 = C_0 Then
               
                If Max2 + Max3 < BMax * 0.8 And Max3 > C_0 Then

                    BCut_Cp3 = RCpo3 + Max3     '前クラスタとのマージ
                    BMax_Cp3 = RCpo3 + Max2 + Max3
                    IDX.Range(IDX.Cells(BCut_Cp3 + C_1, Sp3), IDX.Cells(BMax_Cp3 + C_1, Sp3)).Value = _
                        IDX.Range(IDX.Cells(RCpo2 + C_1, Sp1), IDX.Cells(BMax_Cp2 + C_1, Sp1)).Value
                    IDX.Cells(RCpo3, Sp3) = Max2 + Max3: IDX.Cells(RCpo2, Sp1) = C_0
                    ChX = C_1
                End If
            Else
                If Max2 + Max4 < BMax * 0.8 And Max1 > C_1 Then

                    BCut_Cp2 = RCpo2 + Max2     '後ろクラスタとのマージ
                    BMax_Cp2 = RCpo2 + Max2 + Max4
                    BCut_Cp4 = RCpo4
                    BMax_Cp4 = RCpo4 + Max4
                    IDX.Range(IDX.Cells(BCut_Cp2 + C_1, Sp1), IDX.Cells(BMax_Cp2 + C_1, Sp1)).Value = _
                        IDX.Range(IDX.Cells(BCut_Cp4 + C_1, Sp4), IDX.Cells(BMax_Cp4 + C_1, Sp4)).Value
                    IDX.Cells(RCpo2, Sp1) = Max2 + Max4: IDX.Cells(RCpo4, Sp4) = C_0
                    ChX = C_2
                End If
            End If

            If ChX > C_0 Then '不要クラスタの削除

                Sp0 = Sp0 + ChX - C_1 'サブＩＤを１クラスタ分削除
                With IDX
                    .Range(IDX.Cells(RCpo0 + Sp0 + C_1, 1), IDX.Cells(RCpo0 + Max1 + C_1, 1)).Copy
                    .Range(IDX.Cells(RCpo0 + Sp0, 1), IDX.Cells(RCpo0 + Max1, 1)).PasteSpecial
                End With

                If ChX = C_1 Then

                    IDX.Range(IDX.Cells(RCpo2 + C_1, Sp1), IDX.Cells(RCpo2 + BMax + C_1, Sp1)).Value = _
                        IDX.Range(IDX.Cells(RCpo0 + 4001, 1), IDX.Cells(RCpo0 + BMax + 4001 + C_1, 1)).Value
                Else

                    IDX.Range(IDX.Cells(RCpo4 + C_1, Sp4), IDX.Cells(RCpo4 + BMax + C_1, Sp4)).Value = _
                        IDX.Range(IDX.Cells(RCpo0 + 4001, 1), IDX.Cells(RCpo0 + BMax + 4001 + C_1, 1)).Value
                End If

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

                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