☆エコ・ソート／サンプル〔3〕

'
' Sort Macro
' マクロ記録日 : 2008/9/6 ユーザー名 : 寺田屋の龍馬
'

'　　Ｅｃｏ_Ｓｏｒｔ【エコ・ソート】 Ver.１.０

' シート１のマスターデータ１００万件とシート２のレコードNoを基に
' インデックスを作成、シート３へ出力する。

'
ST$ = Time$

    Dim C As Integer, CP As Integer, R As Integer, F(256) As Long
    Dim C1 As Byte, C2 As Byte, C3 As Byte, ChkDt(), InsID(), IP As Long
    Dim Cp1(256) As Integer, Cp2(256) As Integer, Cp3(256) As Integer
    Dim SC As Integer, SW As Integer, LC As Long, IC As Long
    Dim IMax As Long, RMax As Long, MxC As Integer, C_1 As Byte, C_2 As Byte, Nl As Variant

    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Set S1 = Worksheets("Sheet1")
    Set S2 = Worksheets("Sheet2")
    Set S3 = Worksheets("Sheet3")

    Application.ScreenUpdating = False

    '↓対象レコード数
    IMax = 1000000
    MxC = (IMax - 1) \ 65535 + 1: RMax = 65536: C_1 = 1: C_2 = 2

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

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

    '･･････････････････↓↓↓対象レコードをシート１からシート２へ移動
    For C = 1 To MxC

        CP = C * 2 - 1
        S2.Range(S2.Cells(1, CP), S2.Cells(65535, CP)).Value = S1.Range(S1.Cells(1, C), S1.Cells(65535, C)).Value
    Next

    '･･････････････････↓↓↓対象レコード＋レコードNoを列単位でソート／第１ソート
    For C = 1 To MxC

        CP = C * 2 - 1
        Range(S2.Cells(1, CP), S2.Cells(65535, CP + 1)).Sort Key1:= _
                Range(S2.Cells(1, CP), S2.Cells(65535, CP + 1)), OrderCustom:=1
    Next

    '･･････････････････↓↓↓シート２の作業テーブル全体を配列へ移す
    ChkDt() = S2.Range(S2.Cells(1, 1), S2.Cells(RMax, MxC * 2)).Value

    '･･････････････････↓↓↓作業領域の確保
    InsID() = S3.Range(S3.Cells(1, 255), S3.Cells(RMax, 256)).Value

    '･･････････････････↓↓↓列単位でソートした対象レコード＋レコードNoをまとめてソートし、シート３へ移動／第２ソート
    IP = 0: SC = 1
    Nl = String(16, Chr(0))
    C1 = 1: C2 = 1: C3 = 2
    For IC = 1 To IMax

    C1 = C2
    For R = C3 To MxC

        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), Cp2(C1))
        InsID(IP, 2) = ChkDt(F(C1), Cp3(C1))

        F(C1) = F(C1) - (F(C1) <= 65535)

        If IP = RMax Then
            'ID_Set

            S3.Range(S3.Cells(1, SC), S3.Cells(RMax, SC + 1)).Value = InsID()
            SC = SC + C_2
            IP = 0
        End If

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

    Next
        IC = IC - 1

    '･･････････････････最後の列の調整と保存
    If IP >= 1 Then

        For LC = IP + 1 To RMax
            InsID(LC, 1) = Nl
            InsID(LC, 2) = Nl
        Next

        S3.Range(S3.Cells(1, SC), S3.Cells(RMax, SC + 1)).Value = InsID()
    End If

    Application.ScreenUpdating = True

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

End Sub

ジャンル別一覧