☆エコ・RDB〔9〕マスタ＋IDのセットアップ

801940

Dim C0 As Integer, CP As Integer, R As Integer, F(34) As Long
Dim C1 As Byte, C2 As Byte, C3 As Byte, ChkDt(), InsID(), IP As IntegerDim Cp1(34) As Integer, Cp2(34) As Integer, Cp3(34) As Integer, C_1 As Byte, C_2 As Byte
Dim SC As Integer, SW As Integer, LC As Long, IC As Long, RCpo As Long

Dim MxDt As Long, Sn As Integer, Rn As Long, Cn As Long, Addr As String, FF As String
Dim IMax As Long, WMax As Integer, MxC1 As Integer, MxC2 As Integer, MxC3 As Integer, DivR As Byte
Dim TMP As Worksheet, RDB As Worksheet

Dim TmpS As String, RdbS As String

Sub Make_ID1_RD2()
'
' Make_Index1 Macro
' マクロ記録日 : 2008/10/8 ユーザー名 : 寺田屋の龍馬
'
' 　シート１の１００万件のマスタデータとＩＤをＲＤＢシートへセットアップ

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

TmpS = "Sheet1": RdbS = "Sheet2"

Set TMP = Worksheets(TmpS) Set RDB = Worksheets(RdbS)

MsgBox RDB.Cells(1, 201) + " ＩＤ作成スタート！ "

ST$ = Time$

Application.ScreenUpdating = False

WMax = 501: C_1 = 1: C_2 = 2: FF = String(16, Chr(-1))

        IMax = RDB.Cells(3, 201)
        RCpo = RDB.Cells(4, 201)
        BMax = RDB.Cells(3, 202)
        MxC2 = IMax \ RCpo
        MxC3 = MxC2 + 2
        DivR = 60000 \ RCpo - 1

        Addr = Mid(TMP.Range("A1:AF60000").Find(FF).Address(RowAbsolute:=False), 2)
        Call Worksheet_SelectionChange(RDB.Range(Addr), Rn, Cn)        MxDt = (Cn - 1) * 60000 + Rn - 1
        MxC1 = (MxDt - 1) \ 60000 + 1

    For R = 1 To MxC1
        C1 = R * 2 - 1
        Cp1(R) = C1
        Cp2(R) = C1
        Cp3(R) = C1 + 1
    Next

    For C1 = 1 To MxC1
        F(C1) = 1    Next
    '..................↑↑↑初期設定

    '･･････････････････↓↓↓マスタデータとレコード番号を列単位で併合
    C0 = 35
    For R = 1 To MxC1

        CP = C0 + (R - 1) * 2
        TMP.Range(TMP.Cells(1, CP), TMP.Cells(60000, CP)).Value = TMP.Range(TMP.Cells(1, R), TMP.Cells(60000, R)).Value
    Next

'･･････････････････↓↓↓マスタデータ＋レコード番号を列単位でソート／第１ソート For R = 1 To MxC1 - 1

        CP = C0 + (R - 1) * 2
        TMP.Range(TMP.Cells(1, CP), TMP.Cells(60000, CP + 1)).Sort Key1:= _
                Range(TMP.Cells(1, CP), TMP.Cells(60000, CP + 1)), OrderCustom:=1
    Next
    CP = C0 + (R - 1) * 2
    TMP.Range(TMP.Cells(1, CP), TMP.Cells(Rn - 1, CP + 1)).Sort Key1:= _
            Range(TMP.Cells(1, CP), TMP.Cells(Rn - 1, CP + 1)), OrderCustom:=1

'･･････････････････↓↓↓シート１のインデックス作業テーブルを配列へ移す ChkDt() = TMP.Range(TMP.Cells(1, C0), TMP.Cells(60001, C0 + R * 2 - 1)).Value

    '･･････････････････↓↓↓作業領域の確保
    InsID() = RDB.Range(RDB.Cells(RCpo + 1, 2), RDB.Cells(RCpo + WMax, 2)).Value
    InsID(1, 1) = WMax - 1

   '･･････････････････↓↓↓列単位でソートしたマスタデータ＋レコード番号をまとめてソートし、
   '                        ＲＤＢシートへインデックスを生成／第２ソート
    IP = 1: LC = RCpo + 1: SC = 1: SW = RCpo
    C1 = 1: C2 = 1: C3 = 2
    For IC = 1 To MxDt

C1 = C2 For R = C3 To MxC1

            If ChkDt(F(C1), Cp1(C1)) <= ChkDt(F(R), Cp2(R)) Then
            Else
                    C2 = C1: C1 = R
            End If
        Next

        IP = IP + C_1
        InsID(IP, 1) = ChkDt(F(C1), Cp3(C1))
        F(C1) = F(C1) - (F(C1) <= 60000)

If IP = WMax Then 'ID_Set

SC = SC + C_1 RDB.Range(RDB.Cells(LC, SC), RDB.Cells(LC + InsID(1, 1), SC)).Value = InsID()

SW = SW + C_1 RDB.Cells(SW, 1) = "=R" + CStr(LC + C_1) + "C" + CStr(SC)

            If SC = MxC3 Then
                SC = C_1: LC = LC + BMax + C_2
            End If

IP = C_1 End If

        If C2 = C1 Then
             C2 = C_1: C3 = C_2
        Else
            C3 = C1
        End If

Next IC = IC - C_1

If IP >= 2 Then

InsID(1, 1) = IC Mod (WMax - C_1)

        For CP = (IC Mod (WMax - C_1)) + C_2 To WMax
            InsID(CP, 1) = ""
        Next

SC = SC + C_1 RDB.Range(RDB.Cells(LC, SC), RDB.Cells(LC + InsID(1, 1), SC)).Value = InsID()

SW = SW + C_1 RDB.Cells(SW, 1) = "=R" + CStr(LC + C_1) + "C" + CStr(SC)

End If

    RDB.Cells(1, 202) = SW - RCpo
    RDB.Cells(2, 202) = IC
    RDB.Cells(2, 201) = MxDt

'ＲＤＢシートへマスタデータをコピー Call Tmp_ID(TMP, RDB)

MsgBox "ＩＤ生成完了！ " + Chr$(13) + Chr$(13) + "開始 : " + ST$ + Chr$(13) + Chr$(13) + "終了 : " + Time$ + Chr$(13) + Chr$(13) + "ＩＤ生成件数＝" + Str(IC) + " 件"

Application.ScreenUpdating = True

End Sub

Sub Tmp_ID(TMP As Worksheet, RDB As Worksheet)

C3 = 0 For C1 = 1 To MxC1

For C2 = 0 To DivR

            C3 = C3 + C_1
            TMP.Range(TMP.Cells(RCpo * C2 + C_1, C1), TMP.Cells(RCpo * C2 + RCpo, C1)).Copy
            RDB.Range(RDB.Cells(1, C3), RDB.Cells(RCpo, C3)).PasteSpecial
            If C3 = MxC2 Then C2 = DivR
        Next
    Next

End Sub

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

Rn = Target.Row

Cn = Target.Column

End Sub

ジャンル別一覧