以下は、動作保証をしないので、自己責任で確認のこと。プログラム等その他により生じたいかなる損害等その他について、責任を負いませんので、予めご了承してください。

説明＆メモ

雛型としてクラス処理をする際に必要と思われるものを最低限網羅（追加・削除等その他適宜カスタマイズのこと）

検索キーワード：クラス、Dictionary 、Collection 、関数配列、値渡し、参照渡し、Variant  、 Property ロシージャ 、Implements 、外部参照

類似的なもの：Deep copy、SQL、承継、多様性、マルチタスク的処理（エクセルファイルを複数使用 例 印刷プレビュー処理など）

使用言語：Excel VBA    

ファイル構成：外部参照先のエクセルファイル（クラス系）、メインのエクセルファイル（クラス系がメイン・動作確認用モジュール）

雛型の特徴：Collection、Propertyによるクラスの部品とDictionaryの入れ子構造をもつものもあるメインクラス部品を一つのセットとした各クラス間の部品組み合わせの入門的基礎。モジュール側で関数配列や外部参照により負荷の分散を念頭において、If文や配列処理のネクスト構造をクラスにより簡易化をすることで可読性を向上。クラス設計による多言語移植のサンプルツールからサンプルシステムに資するレベルを目指す。

注：データ件数によりAccessとのソースの移植から組みあ合わせも念頭に、クラス設計を行うための入門的な基礎技術となる構成

注：ページの見やすさを考え、雛型クラス基礎１とか、いろいろ変更予定

雛型クラス基礎サンプル（2020/01/24時点の予定。他のページとの連動もあり、変更する予定ではある）

～コピペしたら、雛型として動作し、カスタマイズする時の起点になるように作成予定。 雛型のため、他のページと重複する場合もある。

～クラスの雛型としては、クラスの基本的な使い方部分。その他の部分は、共通雛型＋ソフト特化部品（例 エクセルならパス指定やシート、セルの使い方など）で、クラスの利用方法的な雛型となる予定。

（共通処理系）-------------------------

 自動起動処理-Access、Word、PowerPointで少し異なる

 呼出関数

 GetBaseName

(Sample) フォルダ・ファイル・パス・コモンダイアログ処理

(Sample) 時間計測

-------------------------

 アドイン処理

（予定）クラスによる階層構造で、プログラムファイルの切り分け処理的なものはTool雛型の方でする予定

-------------------------

 CSV読込処理

Sample:FileSystemObectによるテキストファイルの読み込みと書き込み方法

-------------------------

 Dictionary処理-使用例としてのSample

（Sample）クイックソートによるソート処理-使用例としてのSample（Type型配列）

（Sample）クイックソートによるソート処理-使用例としてのSample（Type型配列+クラス型）

（予定）ADOやObject型による連携はTool雛型の方でする予定

-------------------------

（クラス基礎処理）クラス使用例

（クラス基礎処理）雛型クラス

◇プロジェクトの構造と参照設定

◇メインプロジェクト ProjectClassMain    ファイル名：ProjectClassMain.xlsm

エクセルVBAで基礎的な文法とテクニック、及び使い方と動作確認用

◆ThisWorkbook

◆標準モジュール

【メイン処理】

[標準モジュール名：MAIN]

Public Function test()

    Call ClassCopySample

End Function

■応用例

メインプログラムも画面用、関数処理用などで、参照先の引数にクラスを設定するケースなど多岐にわたる。

■資料

ヘルプファイルやMSDNなど

◇参照先のプロジェクト VBAProject     ファイル名：SampleClass基礎.xlsm

◆ThisWorkbook

【「雛型クラス基礎サンプル」 参照先】

エクセルVBAで基礎的な文法とテクニック、及び使い方と動作確認用

Option Explicit

'Private Sub Workbook_Open()

'    Call アドインインストール

'End Sub

'Private Sub Workbook_BeforeClose(Cancel As Boolean)

'    アドインアインストール

'End Sub

'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

'    

'End Sub

'Private Sub アドインアインストール()

'    On Error Resume Next

'    Application.CommandBars(GetBaseName(Application.ThisWorkbook.Name)).Delete

'End Sub

◆標準モジュール

【自動起動処理】

［標準モジュール名：自動起動処理]

Option Explicit

'自動起動

Sub Auto_Open(Optional ByVal Arg As Variant)

    If VBA.IsMissing(Arg) Then

        '引数なし

    Else

        '引数あり

    End If

End Sub

'Auto_Open関数があるファイルを呼出す関数

Public Sub 呼出関数()

    Dim sFileName As String

    sFileName = "test.xlsx"

    Application.Workbooks.Open Filename:=Application.ThisWorkbook.path & Chr(92) & sFileName, Password:=1, WriteResPassword:=1

    Application.Run Macro:=sFileName & "!Module1.Auto_Open" _

                  , Arg1:="引数に設定する値"

End Sub

Public Function GetBaseName(ByVal path As String) As String

    Dim fs As FileSystemObject

    Set fs = New FileSystemObject

    GetBaseName = fs.GetBaseName(path)

End Function

【(Sample) フォルダ・ファイル・パス・コモンダイアログ処理】

［標準モジュール名：]

Option Explicit

Private Const myFile As String = "Sample.xlsx"

Public mMyPath As String

Public Property Get MyPath() As Variant

    If mMyPath = "" Then

        mMyPath = Application.ThisWorkbook.path & Chr(92) & myFile

    Else

        MyPath = mMyPath

    End If

End Property

Public Property Let MyPath(ByVal vNewValue As Variant)

    If vNewValue = "" Then

        mMyPath = Application.ThisWorkbook.path & Chr(92) & myFile

    Else

        mMyPath = vNewValue

    End If

End Property

Public Function OpenDialog() As String

     Dim c As Long

    Dim items As Variant

     ' Open the file dialog

    With Application.FileDialog(msoFileDialogOpen)

        .AllowMultiSelect = False

        .Filters.Clear

        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm", 1

        .Filters.Add "Test File", "*.txt", 2

        .Filters.Add "その他", "*.*", 3

        .FilterIndex = 1

        If .Show = -1 Then

            If Right(.SelectedItems(1), 3) <> "xls" _

                And Right(.SelectedItems(1), 4) <> "xlsx" _

                And Right(.SelectedItems(1), 4) <> "xlsm" Then

                For Each items In .SelectedItems

                    Debug.Print "Selected item's path: " & items

                Next

            Else

                'Open

                OpenDialog = "Selected item's path: " & .SelectedItems(.SelectedItems.Count)

                .Execute

            End If

        Else

        'Cancel

        End If

'        .Show

'        For c = 1 To .SelectedItems.Count

'            Debug.Print .SelectedItems(c)

'        Next

     End With

End Function

Public Function FolderExistsCheck(ByVal path As String) As Boolean

    'フォルダーがなければ作成。

    Dim flg As Boolean

    Dim fs As FileSystemObject

    flg = False

    Set fs = New FileSystemObject

    If fs.FolderExists(path) = False Then

        fs.CreateFolder (path)

    Else

        flg = True

    End If

    FolderExistsCheck = flg

End Function

Public Function FilesExistsCheck(ByVal path As String) As Boolean

    ' ファイルの有無

    Dim fs As FileSystemObject

    Set fs = New FileSystemObject

    FilesExistsCheck = fs.FileExists(path)

End Function

【(Sample) 時間計測】

［標準モジュール名：]

Option Explicit

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Sub TIMER_SHORI()

    Dim s As Long

    Dim i As Double

    Dim c As Double

    Dim r As String

    c = 0

    s = timeGetTime

    For i = 1 To 100000000

        c = c + 1

    Next

    r = "処理時間:" & Str$((timeGetTime - s) / 1000) & " 秒"

    Debug.Print r

End Sub

【アドイン処理】

［標準モジュール名：アドイン処理]

Public Sub アドインインストール()

    Dim cbrCmdBar As CommandBar

    Dim cbrCmd As CommandBar

    Dim objBtn As CommandBarButton

    Dim objCont As CommandBarControl

    Dim strCBarName As String

    Dim objBarPopup As CommandBarPopup

    On Error Resume Next

    Application.CommandBars(GetBaseName(Application.ThisWorkbook.Name)).Delete

    Set cbrCmdBar = Application.CommandBars.add(Name:=GetBaseName(Application.ThisWorkbook.Name))

    With cbrCmdBar

        .Visible = True

        .Position = msoBarTop 'msoBarFloating

        .Protection = msoBarNoChangeVisible ' ツールバーを非表示にできなくする

    End With

    ' まずボタンを指定してコントロールを追加

    Set objCont = cbrCmdBar.Controls.add(Type:=msoControlButton)

    ' CommandBarButtonオブジェクトの参照を取得

    Set objBtn = objCont

    With objCont

        .BeginGroup = True

    End With

    objBtn.Style = msoButtonCaption         ' ボタン

    objBtn.Caption = "Read"                 ' 表示名

    objBtn.TooltipText = "Read"             ' ツールチップテキスト

    objBtn.OnAction = "Test_OnAction_Cmd"      ' 動作マクロを設定

    ' オブジェクトの参照を廃棄

    Set objBtn = Nothing

    Set objCont = Nothing

    'サブメニュー

    Set objCont = cbrCmdBar.Controls.add(Type:=msoControlPopup)

    ' CommandBarButtonオブジェクトの参照を取得

    With objCont

        .BeginGroup = True

    End With

    Set objBarPopup = objCont

    objBarPopup.Caption = "SUB"                 ' 表示名

    ' オブジェクトの参照を廃棄

    Set objCont = Nothing

    Set objCont = objBarPopup.Controls.add(Type:=msoControlButton)

    ' CommandBarButtonオブジェクトの参照を取得

    Set objBtn = objCont

    With objCont

        .BeginGroup = True

    End With

    objBtn.Style = msoButtonCaption         ' ボタン

    objBtn.Caption = "SUB1"                 ' 表示名

    objBtn.TooltipText = "SUB1"             ' ツールチップテキスト

    objBtn.OnAction = "Test_OnAction_Cmd_SUB1"      ' 動作マクロを設定

    ' オブジェクトの参照を廃棄

    Set objBtn = Nothing

    Set objCont = Nothing

    Set objBarPopup = Nothing

End Sub

【CSV読込処理】

［標準モジュール名：CSV読込処理]

Option Explicit

Sub csvreadfile()

    Dim dstart As Double

    Dim dend As Double

    Dim dnext As Double

    Dim sline As String

    Dim starget As String

    Dim x As Double 'カウント変数

    Dim y As Double 'カウント変数

    'Declare variables.

    Dim fso As New FileSystemObject 'Microsoft Scripting Runtime

    Dim ts As TextStream

    y = 0

    'Open file.

    Set ts = fso.OpenTextFile(Application.ActiveWorkbook.path & "\test.csv")

    'Loop while not at the end of the file.

    Do While Not ts.AtEndOfStream

      'Debug.Print ts.ReadLine

        'セルアドレス行の位置を設定

        y = y + 1

        'ファイルを一行読み込む

        sline = ts.ReadLine

        '初期化

        x = 0

        dnext = 1

        Do Until dnext >= Len(sline)

            starget = ""

            x = x + 1

            dstart = getstartpos(sline, dnext)

'             Debug.Print ";S:" & dstart & ";E:" & dend & ";N:" & dnext

            dend = getendpos(sline, dstart)

'             Debug.Print ";S:" & dstart & ";E:" & dend & ";N:" & dnext

            dnext = getnextpos(sline, dend)

'             Debug.Print ";S:" & dstart & ";E:" & dend & ";N:" & dnext

            'ターゲットを抽出する

            '開始文字が空、若しくは、「'」の区切り記号の場合

            If Mid(sline, dstart, 1) <> """" Or Mid(sline, dstart, 1) <> "'" Then

                '次の開始文字位置を設定

                dstart = dstart + 1

            End If

            starget = Mid(sline, dend, dnext - dstart)

'            Debug.Print starget & ":" & Len(starget)

            Cells(y, x).Value = starget

        Loop

    Loop

    'Close the file.

    ts.Close

End Sub

'ターゲット文字列の抽出開始位置の取得

Function getstartpos(ByVal sender As String, ByVal countpos As Double) As Double

    Dim i As Double 'カウント変数

    For i = countpos To Len(sender)

        '空でループ処理を抜ける

        If Mid(sender, i, 1) = " " Then

            Exit For

        End If

        If Mid(sender, i, 1) = " " Then

            Exit For

        End If

        'TABか改行でループ処理を抜ける

        If (Mid(sender, i, 1) <> Chr(32) And Mid(sender, i, 1) <> "\t") Then

            Exit For

        End If

    Next

    '値を返す

    getstartpos = i

End Function

'ターゲット文字列の抽出終了位置の取得

Function getendpos(ByVal sender As String, ByVal countpos As Double) As Double

    Dim i As Double 'カウント変数

    '指定文字が「,」の区切り記号か否か

    If Mid(sender, countpos, 1) <> "," Then

        '「,」の区切り記号でないなら、値を設定して処理を抜ける

        getendpos = countpos

        Exit Function

    End If

    '「,」の区切り記号の場合の処理

    '「,」の区切り記号の次が空、若しくは、"'"

    For i = countpos To Len(sender)

        '指定文字が空か否か（空空チェック）

        If Mid(sender, countpos, 1) = """" Then

            'ループでカウントしている次の文字が空か否か

            If Mid(sender, i + 1, 1) = """" Then

                '空であるならループ処理を抜ける

                Exit For

            End If

        '指定文字が「'」の区切り記号か否か（''チェック）

        ElseIf Mid(sender, countpos, 1) = "'" Then

            'ループでカウントしている次の文字が「'」の区切り記号か否か

            If Mid(sender, i + 1, 1) = "'" Then

                '「'」であるならループ処理を抜ける

                Exit For

            End If

        '指定文字が「,」の区切り記号か否か

        ElseIf Mid(sender, countpos, 1) = "," Then

            '「,」の区切り記号ならループ処理を抜ける

                Exit For

        End If

    Next

    '値の設定

    getendpos = i

End Function

'ターゲット文字列の抽出終了位置の取得(右詰)

Function getendposRight(ByVal sender As String, ByVal countpos As Double) As Double

    '指定文字が「,」の区切り記号か否か

    If Mid(sender, countpos, 1) <> "," Then

        '「,」の区切り記号でないなら、値を設定して処理を抜ける

        getendposRight = countpos

        Exit Function

    End If

End Function

'次の抽出文字の位置の取得

Function getnextpos(ByVal sender As String, ByVal countpos As Double) As Double

    Dim i As Double 'カウント変数

    For i = countpos To Len(sender)

        '指定文字が「,」の区切り記号か否か

        If Mid(sender, i, 1) = "," Then

            '「,」の区切り記号ならループ処理を抜ける

            Exit For

        End If

    Next

    '次の文字位置を設定

    getnextpos = i + 1

End Function

【Sample:FileSystemObectによるテキストファイルの読み込みと書き込み方法】

［標準モジュール名：]

Option Explicit

Public Sub mWriteLine()

    Dim fs As FileSystemObject

    Dim ts As TextStream

    Set fs = New FileSystemObject 'CreateObject("Scripting.FileSystemObject")

    Set ts = fs.CreateTextFile(Application.ActiveWorkbook.path & "\test.txt", True) 'CreateTextFile("c:\testfile.txt", True)

    ts.WriteLine ("This is a test.")

    ts.Close

End Sub

Public Sub mReadLine()

    Const ForReading = 1, ForWriting = 2

    Dim fs As FileSystemObject

    Dim ts As TextStream

    Dim path As String

    Dim ReadLineTextFile As String

    path = Application.ActiveWorkbook.path & "\test.txt"

    Set fs = New FileSystemObject 'CreateObject("Scripting.FileSystemObject")

    Set ts = fs.CreateTextFile(path, True) 'CreateTextFile("c:\testfile.txt", True)

    ts.WriteLine "Hello world!"

    ts.WriteLine "This is a test."

    ts.Close

    Set ts = fs.OpenTextFile(path, ForReading) 'OpenTextFile("c:\testfile.txt", ForWriting, True)

    ReadLineTextFile = ts.ReadLine

    'ReadLineTextFile = ts.ReadAll

End Sub

Public Sub mOpenAsTextStream()

    Dim fs As FileSystemObject

    Dim ts As TextStream

    Dim path As String

    Dim file As FileSystemObject

    Dim TextStreamTest As String

    Dim x As Double

    Dim y As Double

    x = 1

    y = 1

    path = Application.ActiveWorkbook.path & "\test.txt"

    On Error GoTo cerr

    Set fs = New FileSystemObject

    If fs.FileExists(path) Then

        fs.DeleteFile (path)

    End If

    Set ts = fs.CreateTextFile(path, True)

    Set ts = Nothing

    Set ts = fs.GetFile(path).OpenAsTextStream(ForWriting, TristateUseDefault)

    ts.WriteLine "This"

    ts.WriteLine "is text"

    ts.WriteLine "and test"

    ts.WriteLine "Reading"

    ts.Close

    Set ts = fs.GetFile(path).OpenAsTextStream(ForReading, TristateUseDefault)

    Do While Not ts.AtEndOfStream

        TextStreamTest = ts.ReadLine

        Application.ActiveSheet.Cells(y, x).NumberFormatLocal = "@" '数値 "0_ " 標準 "G/標準"

        Application.ActiveSheet.Cells(y, x).Value = TextStreamTest

        y = y + 1

    Loop

    ts.Close

    Set ts = Nothing

cerr:

    Set fs = Nothing

End Sub

【Dictionary処理】

［標準モジュール名：Dictionary処理]

Option Explicit

Public DictItem As New Scripting.Dictionary

Public ItemBase As New Scripting.Dictionary

Public Item1 As New Scripting.Dictionary

Public Item2 As New Scripting.Dictionary

Public Function mDictItem(ByVal key As String, ByVal sender1 As Variant, ByVal sender2 As Variant)

'    DictItem.add "s", Array(Array(1, 2), Array(3, 4))

'    Debug.Print DictItem("s")(0)(0)

'    Debug.Print DictItem("s")(0)(1)

'    Debug.Print DictItem("s")(1)(0)

'    Debug.Print DictItem("s")(1)(1)

    DictItem.add key, Array(sender1, sender2)

End Function

Public Function mItemBase(ByRef key As String, ByRef sender1 As Variant)

    ItemBase.add key, Array(sender1)

End Function

Public Function mItem1(ByRef key As String, ByRef sender1 As Variant)

    mItem1.add key, Array(sender1)

End Function

Public Function mItem2(ByRef key As String, ByRef sender1 As Variant)

    mItem2.add key, Array(sender1)

End Function

Public Function ディクショナリの入れ子構造()

    Dim vItem As Variant

    Dim vCItem As Variant

    ItemBase.RemoveAll

    Item1.RemoveAll

    Item2.RemoveAll

    Item1.add "Key_Item2_1", "1"

    Item1.add "Key_Item2_2", "2"

'    Debug.Print Item1("Key_Item2_2")

    ItemBase.add "Key_Item1_1", Item1

    Item2.add "Key_Item2_3", "3"

    Item2.add "Key_Item2_4", "4"

    ItemBase.add "Key_Item1_2", Item2

'    Debug.Print Item1("Key_Item1_1")("Key_Item2_4")'Item1.Item("Key_Item1_1")("Key_Item2_2")

    For Each vItem In ItemBase

        Select Case vItem

        Case "Key_Item1_1"

            For Each vCItem In ItemBase(vItem)

                Debug.Print Item1(vCItem)

            Next

        Case "Key_Item1_2"

            For Each vCItem In ItemBase(vItem)

                Debug.Print Item2(vCItem)

            Next

        End Select

    Next

    Item2.RemoveAll

End Function

【（Sample）クイックソートによるソート処理-使用例としてのSample（Type型配列）】

［標準モジュール名：]

Option Explicit

'クイックソート

Public Type Quick

    Key As Double

    Date As Date

    Value1 As Variant

    Value2 As Variant

End Type

Public mQuick() As Quick

Public Sub testQuick()

    Dim c As Long

    ReDim mQuick(4) As Quick

    mQuick(0).Key = 3

    mQuick(0).Date = "2020/02/20"

    mQuick(0).Value1 = "大阪"

    mQuick(0).Value2 = 300

    mQuick(1).Key = 5

    mQuick(1).Date = "2020/02/29"

    mQuick(1).Value1 = "北海道"

    mQuick(1).Value2 = 500

    mQuick(2).Key = 2

    mQuick(2).Date = "2020/02/15"

    mQuick(2).Value1 = "京都"

    mQuick(2).Value2 = 200

    mQuick(3).Key = 1

    mQuick(3).Date = "2020/02/10"

    mQuick(3).Value1 = "東京"

    mQuick(3).Value2 = 100

    mQuick(4).Key = 4

    mQuick(4).Date = "2020/02/25"

    mQuick(4).Value1 = "九州"

    mQuick(4).Value2 = 400

'    Call TypeQuickSortKey(mQuick, 0, 4)

    Call TypeQuickSortDate(mQuick, 0, 4)

    For c = 0 To 4

        Debug.Print mQuick(c).Key

        Debug.Print mQuick(c).Date

        Debug.Print mQuick(c).Value1

        Debug.Print mQuick(c).Value2

    Next

    Debug.Print "=============="

    For c = 4 To 0 Step -1

        Debug.Print mQuick(c).Key

        Debug.Print mQuick(c).Date

        Debug.Print mQuick(c).Value1

        Debug.Print mQuick(c).Value2

    Next

End Sub

Public Sub TypeQuickSortKey(ByRef qitem() As Quick, ByVal idxStart As Long, ByVal idxEnd As Long)

    Dim idxPivot As Long

    If idxEnd - idxStart > 0 Then

        '配列を分割する

        idxPivot = PartitionKey(qitem(), idxStart, idxEnd)

        '左側部分をソートする

        TypeQuickSortKey qitem(), idxStart, idxPivot - 1

        '右側部分をソートする

        TypeQuickSortKey qitem(), idxPivot + 1, idxEnd

    End If

End Sub

Public Function PartitionKey(ByRef qitem() As Quick, ByVal idxStart As Long, ByVal idxEnd As Long)

        Dim pivot As Quick

        Dim i As Long

        Dim j As Long

        Dim temp As Quick

        i = idxStart - 1

        j = idxEnd

        pivot.Key = qitem(idxEnd).Key

        pivot.Date = qitem(idxEnd).Date

        pivot.Value1 = qitem(idxEnd).Value1

        pivot.Value2 = qitem(idxEnd).Value2

        Do While True

            'a(i) >= pivotとなるiを探す

            Do

                i = i + 1

            Loop While qitem(i).Key < pivot.Key

            'a(j) <= pivotとなるjを探す

            Do

                j = j - 1

                If j <= i Then Exit Do

            Loop While qitem(j).Key > pivot.Key

            If j <= i Then Exit Do

            'a(i)とa(j)を交換する

            'Key

            temp.Key = qitem(i).Key

            qitem(i).Key = qitem(j).Key

            qitem(j).Key = temp.Key

            'Date

            temp.Date = qitem(i).Date

            qitem(i).Date = qitem(j).Date

            qitem(j).Date = temp.Date

            'Value1

            temp.Value1 = qitem(i).Value1

            qitem(i).Value1 = qitem(j).Value1

            qitem(j).Value1 = temp.Value1

            'Value2

            temp.Value2 = qitem(i).Value2

            qitem(i).Value2 = qitem(j).Value2

            qitem(j).Value2 = temp.Value2

        Loop

        'a(i)とpivotを交換する

        qitem(idxEnd).Key = qitem(i).Key

        qitem(i).Key = pivot.Key

        'Date

        qitem(idxEnd).Date = qitem(i).Date

        qitem(i).Date = pivot.Date

        'Value1

        qitem(idxEnd).Value1 = qitem(i).Value1

        qitem(i).Value1 = pivot.Value1

        'Value2

        qitem(idxEnd).Value2 = qitem(i).Value2

        qitem(i).Value2 = pivot.Value2

        PartitionKey = i

End Function

Public Sub TypeQuickSortDate(ByRef qitem() As Quick, ByVal idxStart As Long, ByVal idxEnd As Long)

    Dim idxPivot As Long

    If idxEnd - idxStart > 0 Then

        '配列を分割する

        idxPivot = PartitionDate(qitem(), idxStart, idxEnd)

        '左側部分をソートする

        TypeQuickSortDate qitem(), idxStart, idxPivot - 1

        '右側部分をソートする

        TypeQuickSortDate qitem(), idxPivot + 1, idxEnd

    End If

End Sub

Public Function PartitionDate(ByRef qitem() As Quick, ByVal idxStart As Long, ByVal idxEnd As Long)

        Dim pivot As Quick

        Dim i As Long

        Dim j As Long

        Dim temp As Quick

        i = idxStart - 1

        j = idxEnd

        pivot.Key = qitem(idxEnd).Key

        pivot.Date = qitem(idxEnd).Date

        pivot.Value1 = qitem(idxEnd).Value1

        pivot.Value2 = qitem(idxEnd).Value2

        Do While True

            'a(i) >= pivotとなるiを探す

            Do

                i = i + 1

            Loop While qitem(i).Date < pivot.Date

            'a(j) <= pivotとなるjを探す

            Do

                j = j - 1

                If j <= i Then Exit Do

            Loop While qitem(j).Date > pivot.Date

            If j <= i Then Exit Do

            'a(i)とa(j)を交換する

            'Key

            temp.Key = qitem(i).Key

            qitem(i).Key = qitem(j).Key

            qitem(j).Key = temp.Key

            'Date

            temp.Date = qitem(i).Date

            qitem(i).Date = qitem(j).Date

            qitem(j).Date = temp.Date

            'Value1

            temp.Value1 = qitem(i).Value1

            qitem(i).Value1 = qitem(j).Value1

            qitem(j).Value1 = temp.Value1

            'Value2

            temp.Value2 = qitem(i).Value2

            qitem(i).Value2 = qitem(j).Value2

            qitem(j).Value2 = temp.Value2

        Loop

        'a(i)とpivotを交換する

        qitem(idxEnd).Key = qitem(i).Key

        qitem(i).Key = pivot.Key

        'Date

        qitem(idxEnd).Date = qitem(i).Date

        qitem(i).Date = pivot.Date

        'Value1

        qitem(idxEnd).Value1 = qitem(i).Value1

        qitem(i).Value1 = pivot.Value1

        'Value2

        qitem(idxEnd).Value2 = qitem(i).Value2

        qitem(i).Value2 = pivot.Value2

        PartitionDate = i

End Function

【（Sample）クイックソートによるソート処理-使用例としてのSample（Type型配列+クラス型）】

［標準モジュール名：]

Option Explicit

'クイックソート

Public Type QuickClass

    Key As Double 'Key Index

    Date As Date 'Key Date

    sKeyValue As String 'Key address

End Type

Public mQuickClass() As QuickClass

Public Sub ClassCollectionPartsSample_KeyIndex()

    Dim clsC As ClsCollection

    Dim clsPA As Clsparts

    Dim clsPB As Clsparts

    Dim num As Double

    Dim i As Double

    Set clsC = New ClsCollection

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 1 'Key

    clsPA.mAddress = "A3"

    clsPB.mAddress = "B3"

    'Sort用

    clsPA.mKey = 3

    clsPA.mDate = "2020/02/20"

    clsPA.mValue1 = "大阪"

    clsPA.mValue2 = 300

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 2 'Key

    clsPA.mAddress = "A5"

    clsPB.mAddress = "B5"

    'Sort用

    clsPA.mKey = 5

    clsPA.mDate = "2020/02/29"

    clsPA.mValue1 = "北海道"

    clsPA.mValue2 = 500

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 3 'Key

    clsPA.mAddress = "A2"

    clsPB.mAddress = "B2"

    'Sort用

    clsPA.mKey = 2

    clsPA.mDate = "2020/02/15"

    clsPA.mValue1 = "京都"

    clsPA.mValue2 = 200

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 4 'Key

    clsPA.mAddress = "A1"

    clsPB.mAddress = "B1"

    'Sort用

    clsPA.mKey = 1

    clsPA.mDate = "2020/02/10"

    clsPA.mValue1 = "東京"

    clsPA.mValue2 = 100

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 5 'Key

    clsPA.mAddress = "A4"

    clsPB.mAddress = "B4"

    'Sort用

    clsPA.mKey = 4

    clsPA.mDate = "2020/02/25"

    clsPA.mValue1 = "九州"

    clsPA.mValue2 = 400

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

'    '----------------------------------

'    For i = 1 To clsC.clsDictItem.Count

'        Debug.Print clsC.mKey(CStr(i))

'    Next

    Erase mQuickClass

    ReDim mQuickClass(clsC.clsDictItem.Count)

    '----------------------------------

    For i = 0 To clsC.clsDictItem.Count - 1

        mQuickClass(i).Key = clsC.mKey(CStr(i + 1)) 'KeyIndex

        mQuickClass(i).sKeyValue = CStr(i + 1) 'num

    Next

    Call TypeClassQuickSortKey(mQuickClass, 0, clsC.clsDictItem.Count - 1)

     For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print mQuickClass(i).Key

    Next

    For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    Debug.Print "=============="

    For i = clsC.clsDictItem.Count - 1 To 0 Step -1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    '----------------------------------

    Debug.Print "First:" & clsC.mAddress(CStr(1))

    '----------------------------------

    Debug.Print "Last:" & clsC.mAddress(CStr(clsC.clsDictItem.Count))

    clsC.remove CStr(2), clsC.mKey(CStr(2))

    Debug.Print clsC.Exists(CStr(2))

    '----------------------------------

    Set clsC = Nothing

End Sub

Public Sub ClassCollectionPartsSample_KeyAddress()

    Dim clsC As ClsCollection

    Dim clsPA As Clsparts

    Dim clsPB As Clsparts

    Dim num As Double

    Dim i As Double

    Dim item As Variant

    Set clsC = New ClsCollection

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 1 'Key

    clsPA.mAddress = "A3"

    clsPB.mAddress = "B3"

    'Sort用

    clsPA.mKey = 3

    clsPA.mDate = "2020/02/20"

    clsPA.mValue1 = "大阪"

    clsPA.mValue2 = 300

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 2 'Key

    clsPA.mAddress = "A5"

    clsPB.mAddress = "B5"

    'Sort用

    clsPA.mKey = 5

    clsPA.mDate = "2020/02/29"

    clsPA.mValue1 = "北海道"

    clsPA.mValue2 = 500

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 3 'Key

    clsPA.mAddress = "A2"

    clsPB.mAddress = "B2"

    'Sort用

    clsPA.mKey = 2

    clsPA.mDate = "2020/02/15"

    clsPA.mValue1 = "京都"

    clsPA.mValue2 = 200

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 4 'Key

    clsPA.mAddress = "A1"

    clsPB.mAddress = "B1"

    'Sort用

    clsPA.mKey = 1

    clsPA.mDate = "2020/02/10"

    clsPA.mValue1 = "東京"

    clsPA.mValue2 = 100

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 5 'Key

    clsPA.mAddress = "A4"

    clsPB.mAddress = "B4"

    'Sort用

    clsPA.mKey = 4

    clsPA.mDate = "2020/02/25"

    clsPA.mValue1 = "九州"

    clsPA.mValue2 = 400

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mKey), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    Erase mQuickClass

    ReDim mQuickClass(clsC.clsDictItem.Count)

    '----------------------------------

    i = 0

    For Each item In clsC

        mQuickClass(i).Key = item.mKey 'Key index

        mQuickClass(i).sKeyValue = item.mAddress 'Cell Address

        i = i + 1

    Next

    Call TypeClassQuickSortKey(mQuickClass, 0, clsC.clsDictItem.Count - 1)

'    Call TypeClassQuickSortDate(mQuickClass, 0, clsC.clsDictItem.Count - 1)

    For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print mQuickClass(i).Key

    Next

    For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    Debug.Print "=============="

    For i = clsC.clsDictItem.Count - 1 To 0 Step -1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    '----------------------------------

    Debug.Print "First:" & clsC.mAddress(CStr("A3"))

    '----------------------------------

    Debug.Print "Last:" & clsC.mAddress(CStr("A4"))

    clsC.remove CStr("A5"), clsC.mKey(CStr("A5"))

    Debug.Print clsC.Exists(CStr("A5"))

    '----------------------------------

    Set clsC = Nothing

End Sub

Public Sub ClassCollectionPartsSample_KeyDate()

    Dim clsC As ClsCollection

    Dim clsPA As Clsparts

    Dim clsPB As Clsparts

    Dim num As Double

    Dim i As Double

    Set clsC = New ClsCollection

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 1 'Key

    clsPA.mAddress = "A3"

    clsPB.mAddress = "B3"

    'Sort用

    clsPA.mKey = 3

    clsPA.mDate = "2020/02/20"

    clsPA.mValue1 = "大阪"

    clsPA.mValue2 = 300

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 2 'Key

    clsPA.mAddress = "A5"

    clsPB.mAddress = "B5"

    'Sort用

    clsPA.mKey = 5

    clsPA.mDate = "2020/02/29"

    clsPA.mValue1 = "北海道"

    clsPA.mValue2 = 500

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 3 'Key

    clsPA.mAddress = "A2"

    clsPB.mAddress = "B2"

    'Sort用

    clsPA.mKey = 2

    clsPA.mDate = "2020/02/15"

    clsPA.mValue1 = "京都"

    clsPA.mValue2 = 200

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 4 'Key

    clsPA.mAddress = "A1"

    clsPB.mAddress = "B1"

    'Sort用

    clsPA.mKey = 1

    clsPA.mDate = "2020/02/10"

    clsPA.mValue1 = "東京"

    clsPA.mValue2 = 100

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 5 'Key

    clsPA.mAddress = "A4"

    clsPB.mAddress = "B4"

    'Sort用

    clsPA.mKey = 4

    clsPA.mDate = "2020/02/25"

    clsPA.mValue1 = "九州"

    clsPA.mValue2 = 400

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(num), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

'    '----------------------------------

'    For i = 1 To clsC.clsDictItem.Count

'        Debug.Print clsC.mKey(CStr(i))

'    Next

    Erase mQuickClass

    ReDim mQuickClass(clsC.clsDictItem.Count)

    '----------------------------------

    For i = 0 To clsC.clsDictItem.Count - 1

        mQuickClass(i).Date = clsC.mDate(CStr(i + 1))

        mQuickClass(i).sKeyValue = CStr(i + 1) 'num

    Next

    Call TypeClassQuickSortDate(mQuickClass, 0, clsC.clsDictItem.Count - 1)

     For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print mQuickClass(i).Date

    Next

    For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    Debug.Print "=============="

    For i = clsC.clsDictItem.Count - 1 To 0 Step -1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    '----------------------------------

    Debug.Print "First:" & clsC.mAddress(CStr(1))

    '----------------------------------

    Debug.Print "Last:" & clsC.mAddress(CStr(clsC.clsDictItem.Count))

    clsC.remove CStr(2), clsC.mDate(CStr("2"))

    Debug.Print clsC.Exists(CStr(2))

    '----------------------------------

    Set clsC = Nothing

End Sub

Public Sub ClassCollectionPartsSample_KeyAddressDate()

    Dim clsC As ClsCollection

    Dim clsPA As Clsparts

    Dim clsPB As Clsparts

    Dim num As Double

    Dim i As Double

    Dim item As Variant

    Set clsC = New ClsCollection

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 1 'Key

    clsPA.mAddress = "A3"

    clsPB.mAddress = "B3"

    'Sort用

    clsPA.mKey = 3

    clsPA.mDate = "2020/02/20"

    clsPA.mValue1 = "大阪"

    clsPA.mValue2 = 300

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 2 'Key

    clsPA.mAddress = "A5"

    clsPB.mAddress = "B5"

    'Sort用

    clsPA.mKey = 5

    clsPA.mDate = "2020/02/29"

    clsPA.mValue1 = "北海道"

    clsPA.mValue2 = 500

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 3 'Key

    clsPA.mAddress = "A2"

    clsPB.mAddress = "B2"

    'Sort用

    clsPA.mKey = 2

    clsPA.mDate = "2020/02/15"

    clsPA.mValue1 = "京都"

    clsPA.mValue2 = 200

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 4 'Key

    clsPA.mAddress = "A1"

    clsPB.mAddress = "B1"

    'Sort用

    clsPA.mKey = 1

    clsPA.mDate = "2020/02/10"

    clsPA.mValue1 = "東京"

    clsPA.mValue2 = 100

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    '----------------------------------

    Set clsPA = New Clsparts

    Set clsPB = New Clsparts

    num = 5 'Key

    clsPA.mAddress = "A4"

    clsPB.mAddress = "B4"

    'Sort用

    clsPA.mKey = 4

    clsPA.mDate = "2020/02/25"

    clsPA.mValue1 = "九州"

    clsPA.mValue2 = 400

    'Class,Class,value1,uniqueKey1,uniqueKey2,value2

    clsC.add clsPA, clsPB, clsPA.mAddress, CStr(clsPA.mAddress), , , CStr(clsPA.mDate), CStr(clsPA.mDate)

    Set clsPA = Nothing

    Set clsPB = Nothing

    Erase mQuickClass

    ReDim mQuickClass(clsC.clsDictItem.Count)

    '----------------------------------

    i = 0

    For Each item In clsC

        mQuickClass(i).Date = item.mDate 'Key index

        mQuickClass(i).sKeyValue = item.mAddress 'Cell Address

        i = i + 1

    Next

    Call TypeClassQuickSortDate(mQuickClass, 0, clsC.clsDictItem.Count - 1)

    For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print mQuickClass(i).Date

    Next

    For i = 0 To clsC.clsDictItem.Count - 1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    Debug.Print "=============="

    For i = clsC.clsDictItem.Count - 1 To 0 Step -1

        Debug.Print clsC.mKey(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mAddress(CStr(mQuickClass(i).sKeyValue)) & ":--:" _

        & clsC.mDate(CStr(mQuickClass(i).sKeyValue)) & vbCrLf _

        & clsC.mValue1(CStr(mQuickClass(i).sKeyValue)) & ":" _

        & clsC.mValue2(CStr(mQuickClass(i).sKeyValue))

    Next

    '----------------------------------

    Debug.Print "First:" & clsC.mAddress(CStr("A3"))

    '----------------------------------

    Debug.Print "Last:" & clsC.mAddress(CStr("A4"))

    clsC.remove CStr("A5"), clsC.mDate(CStr("A5"))

    Debug.Print clsC.Exists(CStr("A5"))

    '----------------------------------

    Set clsC = Nothing

End Sub

Public Sub TypeClassQuickSortKey(ByRef qitem() As QuickClass, _

                                    ByVal idxStart As Long, _

                                    ByVal idxEnd As Long)

    Dim idxPivot As Long

    If idxEnd - idxStart > 0 Then

        '配列を分割する

        idxPivot = TypeClassPartitionKey(qitem(), idxStart, idxEnd)

        '左側部分をソートする

        TypeClassQuickSortKey qitem(), idxStart, idxPivot - 1

        '右側部分をソートする

        TypeClassQuickSortKey qitem(), idxPivot + 1, idxEnd

    End If

End Sub

Public Function TypeClassPartitionKey(ByRef qitem() As QuickClass, _

                                        ByVal idxStart As Long, _

                                        ByVal idxEnd As Long)

        Dim pivot As QuickClass

        Dim i As Long

        Dim j As Long

        Dim temp As QuickClass

        i = idxStart - 1

        j = idxEnd

        pivot.Key = qitem(idxEnd).Key

        pivot.sKeyValue = qitem(idxEnd).sKeyValue

        Do While True

            'a(i) >= pivotとなるiを探す

            Do

                i = i + 1

            Loop While qitem(i).Key < pivot.Key

            'a(j) <= pivotとなるjを探す

            Do

                j = j - 1

                If j <= i Then Exit Do

            Loop While qitem(j).Key > pivot.Key

            If j <= i Then Exit Do

            'a(i)とa(j)を交換する

            'Key

            temp.Key = qitem(i).Key

            qitem(i).Key = qitem(j).Key

            qitem(j).Key = temp.Key

            'sKeyValue

            temp.sKeyValue = qitem(i).sKeyValue

            qitem(i).sKeyValue = qitem(j).sKeyValue

            qitem(j).sKeyValue = temp.sKeyValue

        Loop

        'a(i)とpivotを交換する

        qitem(idxEnd).Key = qitem(i).Key

        qitem(i).Key = pivot.Key

        'sKeyValue

        qitem(idxEnd).sKeyValue = qitem(i).sKeyValue

        qitem(i).sKeyValue = pivot.sKeyValue

        TypeClassPartitionKey = i

End Function

Public Sub TypeClassQuickSortDate(ByRef qitem() As QuickClass, _

                                    ByVal idxStart As Long, _

                                    ByVal idxEnd As Long)

    Dim idxPivot As Long

    If idxEnd - idxStart > 0 Then

        '配列を分割する

        idxPivot = TypeClassPartitionDate(qitem(), idxStart, idxEnd)

        '左側部分をソートする

        TypeClassQuickSortDate qitem(), idxStart, idxPivot - 1

        '右側部分をソートする

        TypeClassQuickSortDate qitem(), idxPivot + 1, idxEnd

    End If

End Sub

Public Function TypeClassPartitionDate(ByRef qitem() As QuickClass, _

                                        ByVal idxStart As Long, _

                                        ByVal idxEnd As Long)

        Dim pivot As QuickClass

        Dim i As Long

        Dim j As Long

        Dim temp As QuickClass

        i = idxStart - 1

        j = idxEnd

        pivot.Date = qitem(idxEnd).Date

        pivot.sKeyValue = qitem(idxEnd).sKeyValue

        Do While True

            'a(i) >= pivotとなるiを探す

            Do

                i = i + 1

            Loop While qitem(i).Date < pivot.Date

            'a(j) <= pivotとなるjを探す

            Do

                j = j - 1

                If j <= i Then Exit Do

            Loop While qitem(j).Date > pivot.Date

            If j <= i Then Exit Do

            'a(i)とa(j)を交換する

            'Key

            temp.Date = qitem(i).Date

            qitem(i).Date = qitem(j).Date

            qitem(j).Date = temp.Date

            'sKeyValue

            temp.sKeyValue = qitem(i).sKeyValue

            qitem(i).sKeyValue = qitem(j).sKeyValue

            qitem(j).sKeyValue = temp.sKeyValue

        Loop

        'a(i)とpivotを交換する

        qitem(idxEnd).Date = qitem(i).Date

        qitem(i).Date = pivot.Date

        'sKeyValue

        qitem(idxEnd).sKeyValue = qitem(i).sKeyValue

        qitem(i).sKeyValue = pivot.sKeyValue

        TypeClassPartitionDate = i

End Function

【（クラス基礎処理）クラス使用例】

［標準モジュール名：クラス基礎処理]

Option Explicit

' Excel上のSheetの種類

Enum Sheet_type

    Sheet1 = 1    ' Sheet1

    Sheet2 = 2    ' Sheet2

    Sheet3 = 3    ' Sheet3

End Enum

Sub ClassCopySample()

    Dim clsA As New ItemParts

    Dim sData() As String

    Dim i As Integer

    Dim C As Integer

    Dim item As Variant

    Dim map As Collection

    Set map = New Collection

    i = 0

    sData = Split("A,B,C,D,E", ",")

    clsA.item = "Sample1"

    clsA.Hiretu = sData

    clsA.RangePos = Range("A1")

    clsA.SheetType = Sheet1

    ' コレクションにデータ（クラス）追加

    map.add clsA.copy

    sData = Split("1,2,3,4,5", ",")

    clsA.item = "Sample2"

    clsA.Hiretu = sData

    clsA.RangePos = Range("B1")

    clsA.SheetType = Sheet_type.Sheet2

    ' コレクションにデータ（クラス）追加

    map.add clsA.copy

    ' テーブルリストから指定されたテーブル情報を取得

    For Each item In map

        i = i + 1

        Debug.Print "Item Name:" & map(i).item

        Erase sData

        sData = map(i).Hiretu

        '配列1からMaxまで繰り返す

        For C = LBound(sData) + 1 To UBound(sData)

            Debug.Print "配列:" & sData(C)

        Next

        Debug.Print "Range:" & map(i).RangePos.Value

        Debug.Print "シートタイプ:" & map(i).SheetType

    Next

    Set map = Nothing

    Set clsA = Nothing

End Sub

■応用例

アドインメニューの切り替え処理、データ加工、検証、移行作業など多岐にわたる。その他、大雑把には、標準モジュールでは、対応しきれない複雑なデータ構造をもつものや複雑な条件分岐や多重ループを処理する際の高速化などの場合。SQLの方が処理が速いにしても、ネットワーク負荷を避ける場合などでSQLが使えないケースなど、処理件数を分割しつつ処理する場合などもにも考えられる。

注：関数配列などは標準モジュールで使うときで、メモリに常駐するので、よりメモリなどに注意。

■資料

VBAのヘルプファイルやMSDNに文法やテクニックがある。アルゴリズムは古典。

©Hirotoshi Takano