☆エコ・RDB〔9〕マスタ＋IDのセットアップ
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
