アフィリエイト・アドセンス広告を利用しています。詳細は こちら



Excel VBA - 2次元配列 - 行・列方向 - 昇順・降順マージソート(単一・複数キー)処理メモ

Excel VBA でネット上で公開されているマージソートを使った VBA サンプルコードを公開します。

Excel と Excel Visual Basic Editor(VBE)の環境設定については 以前公開した記事 より、VBA コードの基本的な内容については こちらの記事 よりご確認ください。

Excel VBA - 2次元配列 - 行・列方向 - 昇順・降順マージソート(単一・複数キー)処理メモ


マージソート用サンプルファイル(xlsx ファイル)

マージソート用のサンプルファイル(xlsx ファイル)を公開します。サンプルデータの中身は私が適当に用意して作成したものになります。

こちらで作成した マージソートA.xlsx ファイルマージソートB.xlsx ファイル を用意しました。ファイル名リンクをクリックすると Google ドライブからダウンロードするようにしています。

マージソートA.xlsx ファイル は VBA コードを実行する前の状態、マージソートB.xlsx ファイル は VBA コード実行後の処理結果内容となっています。

いずれも xlsx ファイルとなっており VBA コードは含まれていません。VBA コードを実行するにはファイル拡張子が xlsm(マクロ有効ブック)となっている必要がありますが、xlsm 形式での配布は念のため避けています。

VBA コードを実行するには マージソートA.xlsx ファイル をダウンロード後 xlsm 形式に保存、以降各セクションで紹介している VBA コードを各自追加して実行してもらう形としています。

VBA コードの追加方法は VBE のプロジェクトエクスプローラー(Ctrl + R キー)画面にて、開いている VBAProject(ファイル名.xlsm)→「標準モジュール」を開き、右クリックから「挿入」→「標準モジュール」でクリック、追加した標準モジュールに VBA コードを貼り付けることで動作できるようにしています。

クイックソート用 VBA コードと詳細な内容については 次のセクション から説明します。

2次元配列 - 単一・複数キー - 行方向 - 昇順・降順マージソート VBA サンプルコード

以下、2次元配列を対象に指定した単一・複数キーで行方向に昇順・降順にマージソートする VBA サンプルコードです。列方向に昇順・降順マージソートする VBA サンプルコードについては こちら で説明します。

2次元配列用マージソート VBA プログラムを別モジュール(標準モジュール)に登録して、Call ステートメントを使って呼び出してマージソートします。

今回紹介する VBA 用マージソートプログラムは Hiroshi Akutsu さんが公開(Qiitaブログ)したものを一部変更(アルゴリズム部分は変更なし)して利用します。

ここではマージソートを行う昇順および降順プログラムと、ソート対象シートおよび単一 or 複数キーと昇順・降順を指定したシートを 2次元配列に格納してマージソートプログラムを呼び出すプログラムを、それぞれ別々のモジュールに分ける形で紹介します。(関連記事

前回公開したクイックソートプログラム との大きな違いは複数のソートキーの指定が可能で、それぞれのキーに昇順・降順を組み合わせたソートができる、柔軟なソート設定が可能になっている点です。

今回の VBA コードではこちらで用意したシート「List」と 、ソート対象の複数の列名とそれぞれの列名に対する昇順・降順を指定したシート「Order」をそれぞれ 2次元配列に格納して、シート「Order」で指定したソート順にシート「List」のデータを 2次元配列でマージソートで並び替える内容となっています。

2次元配列のデータをマージソート後、シート「ListSort」に転記します。マージソート後の転記先セル内容が確認できるように、転記先シートの該当セルにあらかじめ罫線を囲んであります。

マージソート処理部分以外の基本的な VBA コードについては 以前公開した記事内容 を参照してください。

次のセクション では 2次元配列の複数キーでマージソートを使った VBA コード部分について(ソートアルゴリズム部分を除く)内容を説明します。

その他について以前公開した VBA コードで、LBound と UBound 関数のパラメーターとして配列を返す関数(Split 関数など)を使用すると、メモリリークが起きる可能性があるとの指摘がありました。

ただ、VBA コードのメモリリークについて日本語で言及している情報が少なく、今回公開した VBA コードが原因でメモリリークが起きるかどうか確認できていません。(こちらで単純にメモリリークに気づいていないというのもあります)

こちらのサイト ではメモリリークする・しないコードの書き方が紹介されています。この記事ではこの書き方にならってメモリリーク対策した VBA コードにしています。メモリリークが起きないとされているコード内容に修正しただけなので、実際にメモリリークが起きないかどうかまでは確認していません。

基本的に関数の返り値を一度変数に格納して、その変数を使用する方法に書き換えた内容となっています。メモリリークに対策したコード個所についてはハイライトで表示しておきます。

Option Explicit

Sub merge_sort2_asc_rows(ByRef arr As Variant, ByVal col As Long)

  Dim i As Long
  Dim irekae As Variant
  Dim indexer As Variant
  Dim tmp1() As Variant, tmp2() As Variant

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr_1D As Variant, UB_arr_1D As Variant
  Dim LB_arr_2D As Variant, UB_arr_2D As Variant
  LB_arr_1D = LBound(arr, 1)
  UB_arr_1D = UBound(arr, 1)
  LB_arr_2D = LBound(arr, 2)
  UB_arr_2D = UBound(arr, 2)
  
  ReDim irekae(LB_arr_1D To UB_arr_1D)
  ReDim indexer(LB_arr_1D To UB_arr_1D)
  ReDim tmp1(LB_arr_1D To UB_arr_1D)
  ReDim tmp2(LB_arr_1D To UB_arr_1D)

  For i = LB_arr_1D To UB_arr_1D Step 2
    If i + 1 > UB_arr_1D Then
      irekae(i) = arr(i, col)
      indexer(i) = i
      Exit For
    End If

    If arr(i + 1, col) < arr(i, col) Then
      irekae(i) = arr(i + 1, col)
      irekae(i + 1) = arr(i, col)
      indexer(i) = i + 1
      indexer(i + 1) = i
    Else
      irekae(i) = arr(i, col)
      irekae(i + 1) = arr(i + 1, col)
      indexer(i) = i
      indexer(i + 1) = i + 1
    End If
  Next i

  Dim n As Long
  Dim st1 As Long, st2 As Long
  Dim en1 As Long, en2 As Long

  i = 1

  Do While i * 2 <= UB_arr_1D
    i = i * 2
    n = 0

    Do While en2 + i - 1 < UB_arr_1D
      n = n + 1
      st1 = i * 2 * (n - 1) + LB_arr_1D
      en1 = i * 2 * (n - 1) + i - 1 + LB_arr_1D
      st2 = en1 + 1
      en2 = IIf(st2 + i - 1 >= UB_arr_1D, UB_arr_1D, st2 + i - 1)
      Call merge2asc.merge2asc(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
    Loop

    en2 = 0
  Loop

  Dim ret As Variant
  ReDim ret(LB_arr_1D To UB_arr_1D, LB_arr_2D To UB_arr_2D)

  For i = LB_arr_1D To UB_arr_1D
    For n = LB_arr_2D To UB_arr_2D
      If IsObject(arr(indexer(i), n)) Then
        Set ret(i, n) = arr(indexer(i), n)
      Else
        ret(i, n) = arr(indexer(i), n)
      End If
    Next n
  Next i

  arr = ret

End Sub
Option Explicit

Sub merge2asc(ByRef irekae As Variant, ByRef indexer As Variant, ByRef tmpArr() As Variant, ByRef tmpIndexer() As Variant, ByVal st1 As Long, ByVal en1 As Long, ByVal st2 As Long, ByVal en2 As Long)

  Dim i As Long, j As Long, n As Long

  For i = st1 To en2
    tmpArr(i) = irekae(i)
    tmpIndexer(i) = indexer(i)
  Next i
  
  j = st1
  n = st2

  Do While (j < en1 + 1 Or n < en2 + 1)
    If n >= en2 + 1 Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    ElseIf j < en1 + 1 And tmpArr(j) <= tmpArr(n) Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    Else
      irekae(j + n - st2) = tmpArr(n)
      indexer(j + n - st2) = tmpIndexer(n)
      n = n + 1
    End If
  Loop

End Sub
Option Explicit

Sub merge_sort2_desc_rows(ByRef arr As Variant, ByVal col As Long)

  Dim i As Long
  Dim irekae As Variant
  Dim indexer As Variant
  Dim tmp1() As Variant, tmp2() As Variant

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr_1D As Variant, UB_arr_1D As Variant
  Dim LB_arr_2D As Variant, UB_arr_2D As Variant
  LB_arr_1D = LBound(arr, 1)
  UB_arr_1D = UBound(arr, 1)
  LB_arr_2D = LBound(arr, 2)
  UB_arr_2D = UBound(arr, 2)

  ReDim irekae(LB_arr_1D To UB_arr_1D)
  ReDim indexer(LB_arr_1D To UB_arr_1D)
  ReDim tmp1(LB_arr_1D To UB_arr_1D)
  ReDim tmp2(LB_arr_1D To UB_arr_1D)

  For i = LB_arr_1D To UB_arr_1D Step 2
    If i + 1 > UB_arr_1D Then
      irekae(i) = arr(i, col)
      indexer(i) = i
      Exit For
    End If

    If arr(i + 1, col) > arr(i, col) Then
      irekae(i) = arr(i + 1, col)
      irekae(i + 1) = arr(i, col)
      indexer(i) = i + 1
      indexer(i + 1) = i
    Else
      irekae(i) = arr(i, col)
      irekae(i + 1) = arr(i + 1, col)
      indexer(i) = i
      indexer(i + 1) = i + 1
    End If
  Next i

  Dim n As Long
  Dim st1 As Long, st2 As Long
  Dim en1 As Long, en2 As Long

  i = 1

  Do While i * 2 <= UB_arr_1D
    i = i * 2
    n = 0

    Do While en2 + i - 1 < UB_arr_1D
      n = n + 1
      st1 = i * 2 * (n - 1) + LB_arr_1D
      en1 = i * 2 * (n - 1) + i - 1 + LB_arr_1D
      st2 = en1 + 1
      en2 = IIf(st2 + i - 1 >= UB_arr_1D, UB_arr_1D, st2 + i - 1)
      Call merge2desc.merge2desc(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
    Loop

    en2 = 0
  Loop

  Dim ret As Variant
  ReDim ret(LB_arr_1D To UB_arr_1D, LB_arr_2D To UB_arr_2D)

  For i = LB_arr_1D To UB_arr_1D
    For n = LB_arr_2D To UB_arr_2D
      If IsObject(arr(indexer(i), n)) Then
        Set ret(i, n) = arr(indexer(i), n)
      Else
        ret(i, n) = arr(indexer(i), n)
      End If
    Next n
  Next i

  arr = ret

End Sub
Option Explicit

Sub merge2desc(ByRef irekae As Variant, ByRef indexer As Variant, ByRef tmpArr() As Variant, ByRef tmpIndexer() As Variant, ByVal st1 As Long, ByVal en1 As Long, ByVal st2 As Long, ByVal en2 As Long)

  Dim i As Long, j As Long, n As Long

  For i = st1 To en2
    tmpArr(i) = irekae(i)
    tmpIndexer(i) = indexer(i)
  Next i

  j = st1
  n = st2

  Do While (j < en1 + 1 Or n < en2 + 1)
    If n >= en2 + 1 Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    ElseIf j < en1 + 1 And tmpArr(j) >= tmpArr(n) Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    Else
      irekae(j + n - st2) = tmpArr(n)
      indexer(j + n - st2) = tmpIndexer(n)
      n = n + 1
    End If
  Loop

End Sub
Option Explicit

Sub MergeSortMultipleKeyRowsFixMemoryLeaks() ' メモリリーク対策版
  ' シート「List」内容をシート上で並べ替えずに、2次元配列を使ってマージソートで単一・複数キー(列)を指定して行方向並べ替え

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' 変数宣言
  Dim i As Long ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))

' ----------

  ' 変数宣言
  Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet ' シート格納用オブジェクト変数
  
  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("List") ' ソート元シートをオブジェクト変数にセット
  Set ws2 = ThisWorkbook.Worksheets("Order") ' ソート対象列名と昇順・降順指定シートをオブジェクト変数にセット
  Set ws3 = ThisWorkbook.Worksheets("ListSort") ' ソート転記先シートをオブジェクト変数にセット

  Dim maxrow1 As Long, maxrow2 As Long ' 最終行取得用変数
  Dim maxcol1 As Long, maxcol2 As Long ' 最終列取得用変数

  ' シートの最終行・最終列を取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).row
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
  maxrow2 = ws2.Cells(Rows.Count, "A").End(xlUp).row
  maxcol2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column

' ----------

  ' 変数宣言
  Dim arr1() As Variant, arr2() As Variant ' ソート対象データ格納用動的配列
  ' Dim arr1 As Variant だと「コンパイルエラー:型が一致しません:配列またはユーザー定義型を指定してください。」エラーメッセージ表示
  ' 事前に配列として明示することでエラー回避

  ' シートの指定した範囲内セルを配列としてバリアント型動的配列に格納
  arr1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Value
  arr2 = ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2)).Value

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  arr1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)))
'  arr2 = GetArrFromRange.GetArrFromRange(ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow1, maxcol1)))

' ----------

 ' シート「Order」入力内容チェック

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr1_1D As Variant, UB_arr1_1D As Variant
  Dim LB_arr1_2D As Variant, UB_arr1_2D As Variant
  LB_arr1_1D = LBound(arr1, 1)
  UB_arr1_1D = UBound(arr1, 1)
  LB_arr1_2D = LBound(arr1, 2)
  UB_arr1_2D = UBound(arr1, 2)

  Dim LB_arr2_1D As Variant, UB_arr2_1D As Variant
  Dim LB_arr2_2D As Variant, UB_arr2_2D As Variant
  LB_arr2_1D = LBound(arr2, 1)
  UB_arr2_1D = UBound(arr2, 1)
  LB_arr2_2D = LBound(arr2, 2)
  UB_arr2_2D = UBound(arr2, 2)

  ' 列名チェック
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    If Not (arr2(i, 1) Like "[A-Z,a-z]") And Not (arr2(i, 1) Like "[A-Z,a-z][A-Z,a-z]") And Not (arr2(i, 1) Like "[A-X,a-x][A-F,a-f][A-D,a-d]") Then
      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目の列名がアルファベット以外か最大列(XFD)を超えています" & vbCrLf & "処理を中断します"
      Exit Sub
    End If
  Next i

  ' 列名(アルファベット)を列番号に変換
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    arr2(i, 1) = Columns(arr2(i, 1)).Column ' 列名を列番号に変換
  Next i

  ' ソート対象列範囲チェック
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    If arr2(i, 1) < LB_arr1_2D Or arr2(i, 1) > UB_arr1_2D Then
      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目のソート対象の列名が範囲外です" & vbCrLf & "処理を中断します"
      Exit Sub
    End If
  Next i

  ' ソート対象別昇順(Ascend)・降順(Descend)指定ワードチェック
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    If arr2(i, 2) <> "Ascend" And arr2(i, 2) <> "Descend" Then
      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目に Ascend、Descend 以外の文字があります" & vbCrLf & "処理を中断します"
      Exit Sub
    End If
  Next i

' ----------

  ' マージソート(昇順)プログラム呼び出し例
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え
  ' マージソート(昇順)プログラム呼び出し例
'  Call merge_sort2_desc_rows.merge_sort2_desc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え

  ' マージソートプログラムの仕様かどうか不明だが、複数のソートキー(列)を指定した順序でプログラムを呼び出すと意図したソートにならない
  ' 呼び出し順を逆にすることで意図したソートになるので、Call ステートメントでマージソートプログラムを呼び出す際に逆順で呼び出す
  ' 連続並び替えマージソートプログラム呼び出し例 - 1列目→2列目→3列目の順にすべて昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 3) ' 2次元配列 arr1 に対して 3列目をキーにして昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 2) ' 2次元配列 arr1 に対して 2列目をキーにして昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え

  ' シート「Order」を参照したマージソート(昇順・降順)プログラム呼び出しループ処理
  ' シート「Order」に上から順番に指定した行方向の並べ替えをする場合は、
  ' For 文で開始値を最大要素番号(シート最終行)、終了値を最小要素番号(シート開始行 + 1 = 2行目)にして、
  ' Step でカウンタ変数をデクリメント(-1)して、逆順でソートプログラムを呼び出し
  For i = UB_arr2_1D To LB_arr2_1D Step -1 ' 2次元配列 1次元最小要素までループ処理(デクリメント)
    If arr2(i, 2) = "Ascend" Then
      Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, arr2(i, 1))
    End If
    If arr2(i, 2) = "Descend" Then
      Call merge_sort2_desc_rows.merge_sort2_desc_rows(arr1, arr2(i, 1))
    End If
  Next i

' ----------

  ' シート「ListSort」値クリア
  ws3.Cells.ClearContents

  ' シート「ListSort」フォントサイズ指定
  ws3.Cells.Font.Size = 9

' ----------

  ' 見出し名をシート「ListSort」に転記
  Dim heading() As Variant ' 見出し名格納用動的配列宣言
  
  ' シートの指定した範囲内セルを配列としてバリアント型動的配列に格納
  heading = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, maxcol1)).Value ' シート「List」1行目にある見出し名のみ動的配列に格納

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  heading = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, maxcol1)))

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_heading_2D As Variant, UB_heading_2D As Variant
  LB_heading_2D = LBound(heading, 2)
  UB_heading_2D = UBound(heading, 2)

  ' 2次元配列 heading の内容を、貼り付け先シートの Range で指定したセルから Resize で範囲を変更してセルに代入
  ws3.Range("A1").Resize(LB_heading_2D, UB_heading_2D) = heading

' ----------

  ' 2次元配列 arr1 の内容を、転記先シートの Range で指定したセルから Resize で範囲を変更してセルに代入
  ws3.Range("A2").Resize(UB_arr1_1D, UB_arr1_2D) = arr1
  ws3.Activate

' ----------

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

2次元配列用 - 行方向 - 昇順・降順マージソート VBA プログラム

Option Explicit

Sub merge_sort2_asc_rows(ByRef arr As Variant, ByVal col As Long)

  Dim i As Long
  Dim irekae As Variant
  Dim indexer As Variant
  Dim tmp1() As Variant, tmp2() As Variant

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr_1D As Variant, UB_arr_1D As Variant
  Dim LB_arr_2D As Variant, UB_arr_2D As Variant
  LB_arr_1D = LBound(arr, 1)
  UB_arr_1D = UBound(arr, 1)
  LB_arr_2D = LBound(arr, 2)
  UB_arr_2D = UBound(arr, 2)
  
  ReDim irekae(LB_arr_1D To UB_arr_1D)
  ReDim indexer(LB_arr_1D To UB_arr_1D)
  ReDim tmp1(LB_arr_1D To UB_arr_1D)
  ReDim tmp2(LB_arr_1D To UB_arr_1D)

  For i = LB_arr_1D To UB_arr_1D Step 2
    If i + 1 > UB_arr_1D Then
      irekae(i) = arr(i, col)
      indexer(i) = i
      Exit For
    End If

    If arr(i + 1, col) < arr(i, col) Then
      irekae(i) = arr(i + 1, col)
      irekae(i + 1) = arr(i, col)
      indexer(i) = i + 1
      indexer(i + 1) = i
    Else
      irekae(i) = arr(i, col)
      irekae(i + 1) = arr(i + 1, col)
      indexer(i) = i
      indexer(i + 1) = i + 1
    End If
  Next i

  Dim n As Long
  Dim st1 As Long, st2 As Long
  Dim en1 As Long, en2 As Long

  i = 1

  Do While i * 2 <= UB_arr_1D
    i = i * 2
    n = 0

    Do While en2 + i - 1 < UB_arr_1D
      n = n + 1
      st1 = i * 2 * (n - 1) + LB_arr_1D
      en1 = i * 2 * (n - 1) + i - 1 + LB_arr_1D
      st2 = en1 + 1
      en2 = IIf(st2 + i - 1 >= UB_arr_1D, UB_arr_1D, st2 + i - 1)
      Call merge2asc.merge2asc(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
    Loop

    en2 = 0
  Loop

  Dim ret As Variant
  ReDim ret(LB_arr_1D To UB_arr_1D, LB_arr_2D To UB_arr_2D)

  For i = LB_arr_1D To UB_arr_1D
    For n = LB_arr_2D To UB_arr_2D
      If IsObject(arr(indexer(i), n)) Then
        Set ret(i, n) = arr(indexer(i), n)
      Else
        ret(i, n) = arr(indexer(i), n)
      End If
    Next n
  Next i

  arr = ret

End Sub
Option Explicit

Sub merge2asc(ByRef irekae As Variant, ByRef indexer As Variant, ByRef tmpArr() As Variant, ByRef tmpIndexer() As Variant, ByVal st1 As Long, ByVal en1 As Long, ByVal st2 As Long, ByVal en2 As Long)

  Dim i As Long, j As Long, n As Long

  For i = st1 To en2
    tmpArr(i) = irekae(i)
    tmpIndexer(i) = indexer(i)
  Next i
  
  j = st1
  n = st2

  Do While (j < en1 + 1 Or n < en2 + 1)
    If n >= en2 + 1 Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    ElseIf j < en1 + 1 And tmpArr(j) <= tmpArr(n) Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    Else
      irekae(j + n - st2) = tmpArr(n)
      indexer(j + n - st2) = tmpIndexer(n)
      n = n + 1
    End If
  Loop

End Sub
Option Explicit

Sub merge_sort2_desc_rows(ByRef arr As Variant, ByVal col As Long)

  Dim i As Long
  Dim irekae As Variant
  Dim indexer As Variant
  Dim tmp1() As Variant, tmp2() As Variant

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr_1D As Variant, UB_arr_1D As Variant
  Dim LB_arr_2D As Variant, UB_arr_2D As Variant
  LB_arr_1D = LBound(arr, 1)
  UB_arr_1D = UBound(arr, 1)
  LB_arr_2D = LBound(arr, 2)
  UB_arr_2D = UBound(arr, 2)

  ReDim irekae(LB_arr_1D To UB_arr_1D)
  ReDim indexer(LB_arr_1D To UB_arr_1D)
  ReDim tmp1(LB_arr_1D To UB_arr_1D)
  ReDim tmp2(LB_arr_1D To UB_arr_1D)

  For i = LB_arr_1D To UB_arr_1D Step 2
    If i + 1 > UB_arr_1D Then
      irekae(i) = arr(i, col)
      indexer(i) = i
      Exit For
    End If

    If arr(i + 1, col) > arr(i, col) Then
      irekae(i) = arr(i + 1, col)
      irekae(i + 1) = arr(i, col)
      indexer(i) = i + 1
      indexer(i + 1) = i
    Else
      irekae(i) = arr(i, col)
      irekae(i + 1) = arr(i + 1, col)
      indexer(i) = i
      indexer(i + 1) = i + 1
    End If
  Next i

  Dim n As Long
  Dim st1 As Long, st2 As Long
  Dim en1 As Long, en2 As Long

  i = 1

  Do While i * 2 <= UB_arr_1D
    i = i * 2
    n = 0

    Do While en2 + i - 1 < UB_arr_1D
      n = n + 1
      st1 = i * 2 * (n - 1) + LB_arr_1D
      en1 = i * 2 * (n - 1) + i - 1 + LB_arr_1D
      st2 = en1 + 1
      en2 = IIf(st2 + i - 1 >= UB_arr_1D, UB_arr_1D, st2 + i - 1)
      Call merge2desc.merge2desc(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
    Loop

    en2 = 0
  Loop

  Dim ret As Variant
  ReDim ret(LB_arr_1D To UB_arr_1D, LB_arr_2D To UB_arr_2D)

  For i = LB_arr_1D To UB_arr_1D
    For n = LB_arr_2D To UB_arr_2D
      If IsObject(arr(indexer(i), n)) Then
        Set ret(i, n) = arr(indexer(i), n)
      Else
        ret(i, n) = arr(indexer(i), n)
      End If
    Next n
  Next i

  arr = ret

End Sub
Option Explicit

Sub merge2desc(ByRef irekae As Variant, ByRef indexer As Variant, ByRef tmpArr() As Variant, ByRef tmpIndexer() As Variant, ByVal st1 As Long, ByVal en1 As Long, ByVal st2 As Long, ByVal en2 As Long)

  Dim i As Long, j As Long, n As Long

  For i = st1 To en2
    tmpArr(i) = irekae(i)
    tmpIndexer(i) = indexer(i)
  Next i

  j = st1
  n = st2

  Do While (j < en1 + 1 Or n < en2 + 1)
    If n >= en2 + 1 Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    ElseIf j < en1 + 1 And tmpArr(j) >= tmpArr(n) Then
      irekae(j + n - st2) = tmpArr(j)
      indexer(j + n - st2) = tmpIndexer(j)
      j = j + 1
    Else
      irekae(j + n - st2) = tmpArr(n)
      indexer(j + n - st2) = tmpIndexer(n)
      n = n + 1
    End If
  Loop

End Sub

2次元配列用 - 行方向 - 昇順・降順マージソート VBA プログラムです。内容は Hiroshi Akutsu さんが公開(Qiitaブログ)したものを一部変更(アルゴリズム部分は変更なし)して利用します。

このマージソート VBA プログラムを使うのにあたって次の点に変更を加えています。

プロシージャ名の変更(merge_sort2 → merge_sort2_asc_rows、merge_sort2_desc → merge_sort2_desc_rows、merge2 → merge2asc)、変数宣言を 1行 1変数から 1行複数変数宣言に整理、インデント・改行調整、メモリリーク対策として LBound・UBound 関数格納用変数の宣言と代入をしています。

マージソートを呼び出す側のプログラム から複数の引数(ソート対象の 2次元配列とソートキー)を受け取りマージソート処理をします。

上記マージソート VBA プログラムは受け取ったソート対象の 2次元配列を、同じく受け取った指定したソートキー(列)に対して昇順または降順で並び替えます。4つのモジュールに分けていますが、大まかな流れは以下の通りです。

昇順(小さい順)で並び替えたい場合は、マージソート VBA 昇順プログラム 1 の merge_sort2_asc_rows プロシージャに 2次元配列とソートキーを渡します。59行目の Call ステートメントでマージソート VBA 昇順プログラム 2 の merge2asc プロシージャを呼び出しています。

同様に降順(大きい順)に並び替えたい場合は、マージソート VBA 降順プログラム 1 の merge_sort2_desc_rows プロシージャに 2次元配列とソートキーを渡します。59行目の Call ステートメントでマージソート VBA 降順プログラム 2 の merge2desc プロシージャを呼び出しています。

複数列指定して並び替えたい場合は、昇順・降順に応じて merge_sort2_asc_rows プロシージャ(マージソート VBA 昇順プログラム 1)または merge_sort2_desc_rows プロシージャ(マージソート VBA 降順プログラム 1)を連続で呼び出して、それぞれのプロシージャに並べ替えたいキー(列)を渡すことで、指定した順番に複数列の並べ替えが可能となっています。これについては 次のセクション で説明します。

これにより複数キーによるソート結果が途中まで同値だった場合に最後のソート結果で差異があれば、同値同士内での昇順・降順の並べ替えができることになります。

2次元配列用 - 行方向 - 昇順・降順マージソート呼び出し VBA サンプルコード

Option Explicit

Sub MergeSortMultipleKeyRowsFixMemoryLeaks() ' メモリリーク対策版
  ' シート「List」内容をシート上で並べ替えずに、2次元配列を使ってマージソートで単一・複数キー(列)を指定して行方向並べ替え

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' 変数宣言
  Dim i As Long ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))

' ----------

  ' 変数宣言
  Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet ' シート格納用オブジェクト変数
  
  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("List") ' ソート元シートをオブジェクト変数にセット
  Set ws2 = ThisWorkbook.Worksheets("Order") ' ソート対象列名と昇順・降順指定シートをオブジェクト変数にセット
  Set ws3 = ThisWorkbook.Worksheets("ListSort") ' ソート転記先シートをオブジェクト変数にセット

  Dim maxrow1 As Long, maxrow2 As Long ' 最終行取得用変数
  Dim maxcol1 As Long, maxcol2 As Long ' 最終列取得用変数

  ' シートの最終行・最終列を取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).row
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
  maxrow2 = ws2.Cells(Rows.Count, "A").End(xlUp).row
  maxcol2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column

' ----------

  ' 変数宣言
  Dim arr1() As Variant, arr2() As Variant ' ソート対象データ格納用動的配列
  ' Dim arr1 As Variant だと「コンパイルエラー:型が一致しません:配列またはユーザー定義型を指定してください。」エラーメッセージ表示
  ' 事前に配列として明示することでエラー回避

  ' シートの指定した範囲内セルを配列としてバリアント型動的配列に格納
  arr1 = ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)).Value
  arr2 = ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2)).Value

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  arr1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)))
'  arr2 = GetArrFromRange.GetArrFromRange(ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow1, maxcol1)))

' ----------

 ' シート「Order」入力内容チェック

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr1_1D As Variant, UB_arr1_1D As Variant
  Dim LB_arr1_2D As Variant, UB_arr1_2D As Variant
  LB_arr1_1D = LBound(arr1, 1)
  UB_arr1_1D = UBound(arr1, 1)
  LB_arr1_2D = LBound(arr1, 2)
  UB_arr1_2D = UBound(arr1, 2)

  Dim LB_arr2_1D As Variant, UB_arr2_1D As Variant
  Dim LB_arr2_2D As Variant, UB_arr2_2D As Variant
  LB_arr2_1D = LBound(arr2, 1)
  UB_arr2_1D = UBound(arr2, 1)
  LB_arr2_2D = LBound(arr2, 2)
  UB_arr2_2D = UBound(arr2, 2)

  ' 列名チェック
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    If Not (arr2(i, 1) Like "[A-Z,a-z]") And Not (arr2(i, 1) Like "[A-Z,a-z][A-Z,a-z]") And Not (arr2(i, 1) Like "[A-X,a-x][A-F,a-f][A-D,a-d]") Then
      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目の列名がアルファベット以外か最大列(XFD)を超えています" & vbCrLf & "処理を中断します"
      Exit Sub
    End If
  Next i

  ' 列名(アルファベット)を列番号に変換
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    arr2(i, 1) = Columns(arr2(i, 1)).Column ' 列名を列番号に変換
  Next i

  ' ソート対象列範囲チェック
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    If arr2(i, 1) < LB_arr1_2D Or arr2(i, 1) > UB_arr1_2D Then
      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目のソート対象の列名が範囲外です" & vbCrLf & "処理を中断します"
      Exit Sub
    End If
  Next i

  ' ソート対象別昇順(Ascend)・降順(Descend)指定ワードチェック
  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
    If arr2(i, 2) <> "Ascend" And arr2(i, 2) <> "Descend" Then
      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目に Ascend、Descend 以外の文字があります" & vbCrLf & "処理を中断します"
      Exit Sub
    End If
  Next i

' ----------

  ' マージソート(昇順)プログラム呼び出し例
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え
  ' マージソート(昇順)プログラム呼び出し例
'  Call merge_sort2_desc_rows.merge_sort2_desc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え

  ' マージソートプログラムの仕様かどうか不明だが、複数のソートキー(列)を指定した順序でプログラムを呼び出すと意図したソートにならない
  ' 呼び出し順を逆にすることで意図したソートになるので、Call ステートメントでマージソートプログラムを呼び出す際に逆順で呼び出す
  ' 連続並び替えマージソートプログラム呼び出し例 - 1列目→2列目→3列目の順にすべて昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 3) ' 2次元配列 arr1 に対して 3列目をキーにして昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 2) ' 2次元配列 arr1 に対して 2列目をキーにして昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え

  ' シート「Order」を参照したマージソート(昇順・降順)プログラム呼び出しループ処理
  ' シート「Order」に上から順番に指定した行方向の並べ替えをする場合は、
  ' For 文で開始値を最大要素番号(シート最終行)、終了値を最小要素番号(シート開始行 + 1 = 2行目)にして、
  ' Step でカウンタ変数をデクリメント(-1)して、逆順でソートプログラムを呼び出し
  For i = UB_arr2_1D To LB_arr2_1D Step -1 ' 2次元配列 1次元最小要素までループ処理(デクリメント)
    If arr2(i, 2) = "Ascend" Then
      Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, arr2(i, 1))
    End If
    If arr2(i, 2) = "Descend" Then
      Call merge_sort2_desc_rows.merge_sort2_desc_rows(arr1, arr2(i, 1))
    End If
  Next i

' ----------

  ' シート「ListSort」値クリア
  ws3.Cells.ClearContents

  ' シート「ListSort」フォントサイズ指定
  ws3.Cells.Font.Size = 9

' ----------

  ' 見出し名をシート「ListSort」に転記
  Dim heading() As Variant ' 見出し名格納用動的配列宣言
  
  ' シートの指定した範囲内セルを配列としてバリアント型動的配列に格納
  heading = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, maxcol1)).Value ' シート「List」1行目にある見出し名のみ動的配列に格納

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  heading = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, maxcol1)))

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_heading_2D As Variant, UB_heading_2D As Variant
  LB_heading_2D = LBound(heading, 2)
  UB_heading_2D = UBound(heading, 2)

  ' 2次元配列 heading の内容を、貼り付け先シートの Range で指定したセルから Resize で範囲を変更してセルに代入
  ws3.Range("A1").Resize(LB_heading_2D, UB_heading_2D) = heading

' ----------

  ' 2次元配列 arr1 の内容を、転記先シートの Range で指定したセルから Resize で範囲を変更してセルに代入
  ws3.Range("A2").Resize(UB_arr1_1D, UB_arr1_2D) = arr1
  ws3.Activate

' ----------

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

並び替え対象のデータと、ソートキーと昇順・降順を指定したデータを格納した 2次元配列をそれぞれ引数として、マージソートプログラムを呼び出します。

マージソートプログラムへ引数として渡す前に、ソートキーと昇順・降順を指定したデータ内容の入力チェックについて説明します。

ソートキーと昇順・降順を指定したデータ内容の入力チェックは、69~95行目の間にある For ~ If 文を使って内容のチェックと処理をしています。


69~74行目ではシート「Order」の A 列に入力したソートキーの列名をチェックします。

列名は A 列から XFD 列(16384列)まであるので、これを 70行目の If Not と Like 演算子を組み合わせて A ~ XFD 列名を判定しています。

A ~ XFD 列以外の列名が入力されていれば、71行目で入力内容が間違っているシート名と行番号をメッセージで表示させて、72行目の Exit Sub で Sub プロシージャを終了させています。


69~74行目の列名のチェックで問題がなければ、77~79行目でシート「Order」の A 列に入力したソートキーの列名を列番号に変換して、すでに列名が格納されている 2次元配列に列番号で格納し直します。

列名(アルファベット)から列番号への変換方法については 以前公開した記事 を参照してください。


ソートキーの列名チェック及び列名から列番号への変換が無事終わったら、82~87行目でソート対象データがあるシート「List」の列範囲内にソートキーがあるかどうかチェックします。

チェック方法は 83行目で 2次元配列に格納したソートキーの列番号が、ソート対象のデータを格納した 2次元配列の 2次元の LBound 関数による最小要素番号未満か、UBound 関数による最大要素番号より大きいければ列範囲外として判定しています。

列番号が範囲外であれば、84行目で入力内容が間違っているシート名と行番号をメッセージで表示させて、85行目の Exit Sub で Sub プロシージャを終了させています。


90~95行目ではシート「Order」の B 列に入力した各ソートキー別の昇順・降順指定キーワード名のチェックをします。

今回、この記事では昇順を「Ascend」、降順を「Descend」に設定して、その 2つのキーワード名があるかどうかを 91行目で判定しています。

「Ascend」もしくは「Descend」以外のキーワードが入力されていれば、92行目でキーワードが間違っているシート名と行番号をメッセージで表示させて、93行目の Exit Sub で Sub プロシージャを終了させています。


69~95行目の列名チェック処理をクリア出来たらマージソートプログラムを呼び出します。

使い方は Call ステートメントで 別モジュールに作成した 2次元配列用マージソートプロシージャ を呼び出して引数を指定します。

以下、VBA 用マージソートプログラム作者 Hiroshi Akutsu さん(Qiitaブログ)による使い方の説明です。

なお、この記事では 115~122行目のコードを使って 昇順・降順マージソートプロシージャ を呼び出すため、100行目・102行目・107~109行目の使い方の例ではコメントアウトにして使いません。

100行目は昇順マージソートプロシージャ(merge_sort2_asc_rows)、102行目が降順マージソートプロシージャ(merge_sort2_desc_rows)の呼び出し例です。ソートキーが一つ(単一キー)だけのソート指定方法です。

昇順・降順マージソートプロシージャ の第 1引数に 42行目でソート対象のデータを格納した 2次元配列 arr1 を指定、第 2引数にソート対象 2次元配列のソートキー(列番号)を指定します。2次元配列の列番号を直接指定する方法のため、この書き方の場合ならシート「Order」および 69~95行目のシート「Order」の列名チェック処理は不要になります。

複数のソートキーを指定してソートしたい場合は 107~109行目のように、ソートキーの数だけ連続してマージソートプロシージャを呼び出します。第 1引数はそのままで、第 2引数にソートしたい順番にソートキー(列番号)を指定します。(ブログコメント 4 に記載)(Hiroshi Akutsu さんによる使い方の説明はここまで)

ここで注意したいのが複数列のソート順を 1(A 列)→ 2(B 列)→ 3(C 列)の順番としたい場合は、107~109行目のように昇順・降順マージソートプロシージャの第 2引数を 3(C 列)→ 2(B 列)→ 1(A 列)の順番に指定しないと意図したソートができません。マージソートプログラムの仕様なのか作者のミスなのかどうかわかりませんが、この順序でプロシージャを呼び出せば指定した通りにソートできることを一応確認しています。


100行目・102行目や 107~109行目で 昇順・降順マージソートプロシージャ を呼び出す方法ではソートしたい列や昇順・降順を変更したいときに、毎回 VBA コードの修正が必要になります。

そこで思いついたのが、ソートキー(列名)と昇順・降順を指定したシート「Order」をあらかじめ用意して、その入力内容から 昇順・降順マージソートプロシージャ を自動的に呼び出す方法です。

これを 115~122行目の For ~ If 文によるループ処理と判定処理を使って Call ステートメントを連続して呼び出せるようにしています。

115行目の For 文でシート「Order」を格納した 2次元配列 arr2 の 1次元の最大要素までループさせることで、複数のソートキーを指定した場合の Call ステートメントによる、昇順・降順マージソートプロシージャ を繰り返し呼び出しことができます。

116行目と 119行目の If 文でシート「Order」を格納した 2次元配列 arr2 の 2列目にあるソート方法のキーワード内容に応じて、「Ascend」(昇順)なら 117行目に、「Descend」(降順)なら 120行目の Call ステートメントを使って 昇順・降順マージソートプロシージャ を呼び出します。

この時 昇順・降順マージソートプロシージャ の第 2引数には 115行目のカウンタ変数 i を行番号として、シート「Order」を格納した 2次元配列 arr2 の 1列目に、78行目の列名(アルファベット)から変換した列番号を格納した arr2(i, 1) を指定しています。

以上のループ処理と判定処理で Call ステートメントで指定したソート方法を 昇順・降順マージソートプロシージャ で繰り返し呼び出すことができます。

2次元配列 - 単一キー - 列方向 - 昇順・降順マージソート VBA サンプルコード

以下、2次元配列を対象に指定した単一キーで列方向に昇順・降順マージソートする VBA サンプルコードです。

並び替えの一般的な使い方としては、指定した列をキーとして各行を昇順・降順で並び替えることかと思いますが、こちらは指定した行をキーとして各列を昇順・降順に並び替えることができます。

前回公開した 列方向 - 昇順・降順クイックソート と同じ結果が得られることが期待できますが、クイックソートは不安定ソートのため同じ値同士の場合、元のデータから順序が入れ替わってしまうことがあります。(参考情報

マージソートは安定ソートのため、ソート後同じ値での順序関係を維持します。クイックソートのようにソート後、元のデータから順序が入れ替わることはありません。

行方向の昇順・降順マージソートプログラム 1(2次元配列とソートキー渡し先関数) と基本的に同じコード(アルゴリズム)内容のままで、プログラム内にある 2次元配列の行と列の変数と、ループ処理のカウンタ変数に代入する 2次元配列の次元を入れ替えることで、列の並び替えができるようになっています。

ただ、こちらの思い付きで改造したものであり、入念に動作テストしたわけではないので、意図せぬ動作・結果が発生するかもしれません。


以下各 VBA コードの変更点について説明をします。

列方向 - 昇順・降順マージソート VBA プログラム 1(2次元配列とソートキー渡し先関数)のハイライトしてあるコード内容について。

3行目のプロシージャの第 2引数名を col から row に変更しています。こちらは変更しなくも問題ありませんが、行方向の昇順・降順マージソートプログラム 1(2次元配列とソートキー渡し先関数) で使っている第 2引数名 col と区別するために変更する形にしています。これにあわせて以降、各行にあった変数 col を row にまとめて変換しています。

66行目および 68~69行目を除く、行方向の昇順・降順マージソートプログラム 1(2次元配列とソートキー渡し先関数) の各行で指定した、2次元配列 arr の 1次元の最小・最大要素番号を格納した変数から、2次元の最小・最大要素番号を格納した変数に変更しています。

各行にある引数として受け取った 2次元配列 arr の行と列にある変数・値をすべて逆に入れ替えています。ちなみに 70~71行目および 73行目については、arr(indexer(i), n) から arr(i, indexer(n)) という形にしています。

以上の変更内容で並べ替えに必要な引数を受け取ることで、行方向から列方向への昇順・降順の並び替えができることを確認しています。

なお、行方向の昇順・降順マージソートプログラム 2(昇順・降順プログラム 1 から呼び出される関数) についてはコード内容の変更はありません。

Option Explicit

Sub merge_sort2_asc_columns(ByRef arr As Variant, ByVal row As Long)

  Dim i As Long
  Dim irekae As Variant
  Dim indexer As Variant
  Dim tmp1() As Variant, tmp2() As Variant

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr_1D As Variant, UB_arr_1D As Variant
  Dim LB_arr_2D As Variant, UB_arr_2D As Variant
  LB_arr_1D = LBound(arr, 1)
  UB_arr_1D = UBound(arr, 1)
  LB_arr_2D = LBound(arr, 2)
  UB_arr_2D = UBound(arr, 2)
  
  ReDim irekae(LB_arr_2D To UB_arr_2D)
  ReDim indexer(LB_arr_2D To UB_arr_2D)
  ReDim tmp1(LB_arr_2D To UB_arr_2D)
  ReDim tmp2(LB_arr_2D To UB_arr_2D)

  For i = LB_arr_2D To UB_arr_2D Step 2
    If i + 1 > UB_arr_2D Then
      irekae(i) = arr(row, i)
      indexer(i) = i
      Exit For
    End If

    If arr(row, i + 1) < arr(row, i) Then
      irekae(i) = arr(row, i + 1)
      irekae(i + 1) = arr(row, i)
      indexer(i) = i + 1
      indexer(i + 1) = i
    Else
      irekae(i) = arr(row, i)
      irekae(i + 1) = arr(row, i + 1)
      indexer(i) = i
      indexer(i + 1) = i + 1
    End If
  Next i

  Dim n As Long
  Dim st1 As Long, st2 As Long
  Dim en1 As Long, en2 As Long

  i = 1

  Do While i * 2 <= UB_arr_2D
    i = i * 2
    n = 0

    Do While en2 + i - 1 < UB_arr_2D
      n = n + 1
      st1 = i * 2 * (n - 1) + LB_arr_2D
      en1 = i * 2 * (n - 1) + i - 1 + LB_arr_2D
      st2 = en1 + 1
      en2 = IIf(st2 + i - 1 >= UB_arr_2D, UB_arr_2D, st2 + i - 1)
      Call merge2asc.merge2asc(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
    Loop

    en2 = 0
  Loop

  Dim ret As Variant
  ReDim ret(LB_arr_1D To UB_arr_1D, LB_arr_2D To UB_arr_2D)

  For i = LB_arr_1D To UB_arr_1D
    For n = LB_arr_2D To UB_arr_2D
      If IsObject(arr(i, indexer(n))) Then
        Set ret(i, n) = arr(i, indexer(n))
      Else
        ret(i, n) = arr(i, indexer(n))
      End If
    Next n
  Next i

  arr = ret

End Sub
Option Explicit

Sub merge_sort2_desc_columns(ByRef arr As Variant, ByVal row As Long)

  Dim i As Long
  Dim irekae As Variant
  Dim indexer As Variant
  Dim tmp1() As Variant, tmp2() As Variant

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr_1D As Variant, UB_arr_1D As Variant
  Dim LB_arr_2D As Variant, UB_arr_2D As Variant
  LB_arr_1D = LBound(arr, 1)
  UB_arr_1D = UBound(arr, 1)
  LB_arr_2D = LBound(arr, 2)
  UB_arr_2D = UBound(arr, 2)

  ReDim irekae(LB_arr_2D To UB_arr_2D)
  ReDim indexer(LB_arr_2D To UB_arr_2D)
  ReDim tmp1(LB_arr_2D To UB_arr_2D)
  ReDim tmp2(LB_arr_2D To UB_arr_2D)

  For i = LB_arr_2D To UB_arr_2D Step 2
    If i + 1 > UB_arr_2D Then
      irekae(i) = arr(row, i)
      indexer(i) = i
      Exit For
    End If

    If arr(row, i + 1) > arr(row, i) Then
      irekae(i) = arr(row, i + 1)
      irekae(i + 1) = arr(row, i)
      indexer(i) = i + 1
      indexer(i + 1) = i
    Else
      irekae(i) = arr(row, i)
      irekae(i + 1) = arr(row, i + 1)
      indexer(i) = i
      indexer(i + 1) = i + 1
    End If
  Next i

  Dim n As Long
  Dim st1 As Long, st2 As Long
  Dim en1 As Long, en2 As Long

  i = 1

  Do While i * 2 <= UB_arr_2D
    i = i * 2
    n = 0

    Do While en2 + i - 1 < UB_arr_2D
      n = n + 1
      st1 = i * 2 * (n - 1) + LB_arr_2D
      en1 = i * 2 * (n - 1) + i - 1 + LB_arr_2D
      st2 = en1 + 1
      en2 = IIf(st2 + i - 1 >= UB_arr_2D, UB_arr_2D, st2 + i - 1)
      Call merge2desc.merge2desc(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
    Loop

    en2 = 0
  Loop

  Dim ret As Variant
  ReDim ret(LB_arr_1D To UB_arr_1D, LB_arr_2D To UB_arr_2D)

  For i = LB_arr_1D To UB_arr_1D
    For n = LB_arr_2D To UB_arr_2D
      If IsObject(arr(i, indexer(n))) Then
        Set ret(i, n) = arr(i, indexer(n))
      Else
        ret(i, n) = arr(i, indexer(n))
      End If
    Next n
  Next i

  arr = ret

End Sub

以下、列方向 - 昇順・降順マージソート呼び出しプログラムのハイライトしてあるコード内容について。

42行目の Cells プロパティによるセル範囲の指定で、2行目から 1行目からに変更しています。これは列方向の並べ替えの場合、見出し部分も連動して並べ替えするためです。

125行目と128行目の Call ステートメントで行方向 - 昇順・降順マージソートプロシージャを呼び出し、第 2引数にソートキーである 2次元配列の行番号を指定しています。1 の場合は 1行目(ここでは各列の見出し部分)を指していることになります。

160行目の指定したシートのセル範囲に転記する際の Range プロパティの開始セルを、42行目のセル範囲指定とあわせるため A2 セルから A1 セルに変更しています。

以上の変更内容でマージソートプログラムに必要な引数を渡すことで、列方向への昇順・降順で並び替えたデータを受け取ることができます。

Option Explicit

Sub MergeSortSingleKeyColumnsFixMemoryLeaks() ' メモリリーク対策版
  ' シート「List」内容をシート上で並べ替えずに、2次元配列を使ってマージソートで単一(行)を指定して列方向並べ替え

  ' 実行速度計測開始
  Dim starttime As Double
  starttime = Timer

' ----------

  ' 変数宣言
  Dim i As Long ' カウンタ用変数(一見見分けにくい文字同士を組み合わせない形、i と j、m と n、o(オー) と 0(ゼロ))

' ----------

  ' 変数宣言
  Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet ' シート格納用オブジェクト変数
  
  ' オブジェクト変数にシートセット
  Set ws1 = ThisWorkbook.Worksheets("List") ' ソート元シートをオブジェクト変数にセット
'  Set ws2 = ThisWorkbook.Worksheets("Order") ' ソート対象列名と昇順・降順指定シートをオブジェクト変数にセット
  Set ws3 = ThisWorkbook.Worksheets("ListSort") ' ソート転記先シートをオブジェクト変数にセット

  Dim maxrow1 As Long, maxrow2 As Long ' 最終行取得用変数
  Dim maxcol1 As Long, maxcol2 As Long ' 最終列取得用変数

  ' シートの最終行・最終列を取得して変数に格納
  maxrow1 = ws1.Cells(Rows.Count, "A").End(xlUp).row
  maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
'  maxrow2 = ws2.Cells(Rows.Count, "A").End(xlUp).row
'  maxcol2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column

' ----------

  ' 変数宣言
  Dim arr1() As Variant, arr2() As Variant ' ソート対象データ格納用動的配列
  ' Dim arr1 As Variant だと「コンパイルエラー:型が一致しません:配列またはユーザー定義型を指定してください。」エラーメッセージ表示
  ' 事前に配列として明示することでエラー回避

  ' シートの指定した範囲内セルを配列としてバリアント型動的配列に格納
  arr1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(maxrow1, maxcol1)).Value
'  arr2 = ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow2, maxcol2)).Value

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  arr1 = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(2, 1), ws1.Cells(maxrow1, maxcol1)))
'  arr2 = GetArrFromRange.GetArrFromRange(ws2.Range(ws2.Cells(2, 1), ws2.Cells(maxrow1, maxcol1)))

' ----------

 ' シート「Order」入力内容チェック

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
  Dim LB_arr1_1D As Variant, UB_arr1_1D As Variant
  Dim LB_arr1_2D As Variant, UB_arr1_2D As Variant
  LB_arr1_1D = LBound(arr1, 1)
  UB_arr1_1D = UBound(arr1, 1)
  LB_arr1_2D = LBound(arr1, 2)
  UB_arr1_2D = UBound(arr1, 2)

'  Dim LB_arr2_1D As Variant, UB_arr2_1D As Variant
'  Dim LB_arr2_2D As Variant, UB_arr2_2D As Variant
'  LB_arr2_1D = LBound(arr2, 1)
'  UB_arr2_1D = UBound(arr2, 1)
'  LB_arr2_2D = LBound(arr2, 2)
'  UB_arr2_2D = UBound(arr2, 2)

  ' 列名チェック
'  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
'    If Not (arr2(i, 1) Like "[A-Z,a-z]") And Not (arr2(i, 1) Like "[A-Z,a-z][A-Z,a-z]") And Not (arr2(i, 1) Like "[A-X,a-x][A-F,a-f][A-D,a-d]") Then
'      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目の列名がアルファベット以外か最大列(XFD)を超えています" & vbCrLf & "処理を中断します"
'      Exit Sub
'    End If
'  Next i

  ' 列名(アルファベット)を列番号に変換
'  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
'    arr2(i, 1) = Columns(arr2(i, 1)).Column ' 列名を列番号に変換
'  Next i

  ' ソート対象列範囲チェック
'  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
'    If arr2(i, 1) < LB_arr1_2D Or arr2(i, 1) > UB_arr1_2D Then
'      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目のソート対象の列名が範囲外です" & vbCrLf & "処理を中断します"
'      Exit Sub
'    End If
'  Next i

  ' ソート対象別昇順(Ascend)・降順(Descend)指定ワードチェック
'  For i = LB_arr2_1D To UB_arr2_1D ' 1次元配列最大要素までループ処理
'    If arr2(i, 2) <> "Ascend" And arr2(i, 2) <> "Descend" Then
'      MsgBox "シート「" & ws2.Name & "」" & i + 1 & "行目に Ascend、Descend 以外の文字があります" & vbCrLf & "処理を中断します"
'      Exit Sub
'    End If
'  Next i

' ----------

  ' マージソート(昇順)プログラム呼び出し例
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え
  ' マージソート(昇順)プログラム呼び出し例
'  Call merge_sort2_desc_rows.merge_sort2_desc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え

  ' マージソートプログラムの仕様かどうか不明だが、複数のソートキー(列)を指定した順序でプログラムを呼び出すと意図したソートにならない
  ' 呼び出し順を逆にすることで意図したソートになるので、Call ステートメントでマージソートプログラムを呼び出す際に逆順で呼び出す
  ' 連続並び替えマージソートプログラム呼び出し例 - 1列目→2列目→3列目の順にすべて昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 3) ' 2次元配列 arr1 に対して 3列目をキーにして昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 2) ' 2次元配列 arr1 に対して 2列目をキーにして昇順で行方向並べ替え
'  Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, 1) ' 2次元配列 arr1 に対して 1列目をキーにして昇順で行方向並べ替え

  ' シート「Order」を参照したマージソート(昇順・降順)プログラム呼び出しループ処理
  ' シート「Order」に上から順番に指定した行方向の並べ替えをする場合は、
  ' For 文で開始値を最大要素番号(シート最終行)、終了値を最小要素番号(シート開始行 + 1 = 2行目)にして、
  ' Step でカウンタ変数をデクリメント(-1)して、逆順でソートプログラムを呼び出し
'  For i = UB_arr2_1D To LB_arr2_1D Step -1 ' 2次元配列 1次元最小要素までループ処理(デクリメント)
'    If arr2(i, 2) = "Ascend" Then
'      Call merge_sort2_asc_rows.merge_sort2_asc_rows(arr1, arr2(i, 1))
'    End If
'    If arr2(i, 2) = "Descend" Then
'      Call merge_sort2_desc_rows.merge_sort2_desc_rows(arr1, arr2(i, 1))
'    End If
'  Next i

  ' マージソート(昇順・列方向)
  Call merge_sort2_asc_columns.merge_sort2_asc_columns(arr1, 1)

  ' マージソート(降順・列方向)
'  Call merge_sort2_desc_columns.merge_sort2_desc_columns(arr1, 1)

' ----------

  ' シート「ListSort」値クリア
  ws3.Cells.ClearContents

  ' シート「ListSort」フォントサイズ指定
  ws3.Cells.Font.Size = 9

' ----------

  ' 見出し名をシート「ListSort」に転記
'  Dim heading() As Variant ' 見出し名格納用動的配列宣言
  
  ' シートの指定した範囲内セルを配列としてバリアント型動的配列に格納
'  heading = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, maxcol1)).Value ' シート「List」1行目にある見出し名のみ動的配列に格納

  ' Range オブジェクトを受け取り、2次元配列で返す自作関数 GetArrFromRange
'  heading = GetArrFromRange.GetArrFromRange(ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, maxcol1)))

  ' LBound・UBound 関数格納用変数と代入(メモリリーク対策)
'  Dim LB_heading_2D As Variant, UB_heading_2D As Variant
'  LB_heading_2D = LBound(heading, 2)
'  UB_heading_2D = UBound(heading, 2)

  ' 2次元配列 heading の内容を、貼り付け先シートの Range で指定したセルから Resize で範囲を変更してセルに代入
'  ws3.Range("A1").Resize(LB_heading_2D, UB_heading_2D) = heading

' ----------

  ' 2次元配列 arr1 の内容を、転記先シートの Range で指定したセルから Resize で範囲を変更してセルに代入
  ws3.Range("A1").Resize(UB_arr1_1D, UB_arr1_2D) = arr1
  ws3.Activate

' ----------

  ' 実行速度計測結果表示
  Debug.Print Format(Timer - starttime, "0.00秒")

End Sub

その他、既存のマージソートプログラムを使って列方向を昇順・降順にソートするには次の手順が考えられます。

ソート対象のデータを Transpose 関数か For 文による 2次元配列のループ処理で、2次元配列の 1次元と 2次元の各要素を入れ替え ます。

1次元と 2次元の各要素を入れ替えた 2次元配列に対してマージソートプログラムを実行してソートします。

ソート後、再度 Transpose 関数か For 文で、2次元配列の 1次元と 2次元の各要素を入れ替え て戻すことでソート完了となります。

ただし、Transpose 関数を使う場合は要素数が 65536 を超えるとエラーになるようなので、その場合は For 文を使った 2次元配列の 1次元と 2次元の各要素を入れ替えるプログラムを使うことになります。