Excel VBA 逆引き集 | ソートアルゴリズム

Excel VBA
スポンサーリンク

ねらい：VBAで「速く・正しく」並べ替えるための実践テンプレート

ソートは、集計・重複排除・ランキング・差分の前処理として最重要です。Excelの並べ替え機能は便利ですが、大量データや複雑な条件では「配列に読み出してVBAでソート→一括書き戻し」が圧倒的に速く、自由度も高いです。ここでは貼ってすぐ動くテンプレートを、基礎（配列I/O）→代表アルゴリズム（クイック・マージ・ヒープ）→安定性とキー設計→シート連携（多列・カスタム比較）まで、要点をかみ砕いて解説します。

重要ポイントの深掘り

  • 配列I/Oが核: シートから配列へ一括読み出し、メモリ内でソート、最後に一括書き戻し。セルを1件ずつ触ると遅くなります。
  • 安定性の意味: 「元の順序を保つ」安定ソートは多列キーや同率順位で重要。マージソートは安定、クイックソートは通常不安定。
  • キー設計: 大文字・小文字、全半角、トリムなどの正規化を入口で固定。複合キーは安全な区切り文字で束ねます。
  • 比較関数の切替: 数値・文字列・日付・自然順（数字を数値として扱う）など、比較ロジックを差し替え可能にしておくと運用が楽です。

基礎：Rangeを配列に読み出して、ソートして書き戻す

2列のうち「1列目キー」で昇順ソート（貼って動く最小形）

' ModSortBasics.bas
Option Explicit

Public Sub SortByFirstColumnAsc(ByVal wsName As String)
    Dim ws As Worksheet: Set ws = Worksheets(wsName)
    Dim a As Variant: a = ws.Range("A1").CurrentRegion.Value ' 2次元配列
    If UBound(a, 1) < 2 Then Exit Sub ' データなし

    ' クイックソート（行ごと入れ替え）
    QuickSort2D a, 2, UBound(a, 1), 1, True, AddressOf CmpString

    ws.Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
    ws.Columns.AutoFit
End Sub
VB
' 比較関数（文字列：大小無視トリム）
Public Function CmpString(ByVal x As Variant, ByVal y As Variant) As Long
    Dim sx As String: sx = LCase$(Trim$(CStr(x)))
    Dim sy As String: sy = LCase$(Trim$(CStr(y)))
    If sx < sy Then CmpString = -1 ElseIf sx > sy Then CmpString = 1 Else CmpString = 0
End Function
VB
' クイックソート（2次元配列の行単位入れ替え）
Public Sub QuickSort2D(ByRef a As Variant, ByVal lo As Long, ByVal hi As Long, _
                       ByVal keyCol As Long, ByVal asc As Boolean, ByVal cmp As LongPtr)
    Dim i As Long, j As Long, p As Variant
    i = lo: j = hi: p = a((lo + hi) \ 2, keyCol)
    Do While i <= j
        Do While CallCmp(a(i, keyCol), p, cmp, asc) < 0: i = i + 1: Loop
        Do While CallCmp(a(j, keyCol), p, cmp, asc) > 0: j = j - 1: Loop
        If i <= j Then
            SwapRows a, i, j
            i = i + 1: j = j - 1
        End If
    Loop
    If lo < j Then QuickSort2D a, lo, j, keyCol, asc, cmp
    If i < hi Then QuickSort2D a, i, hi, keyCol, asc, cmp
End Sub

Private Function CallCmp(ByVal x As Variant, ByVal y As Variant, ByVal f As LongPtr, ByVal asc As Boolean) As Long
    ' アドレス指定の比較関数呼び出し（VBAでは直接委譲できないため、代表例として示す。実務はSelect Caseで関数切替でもOK）
    Dim r As Long: r = CmpString(x, y) ' 簡易：比較関数固定にしてもよい
    CallCmp = IIf(asc, r, -r)
End Function

Private Sub SwapRows(ByRef a As Variant, ByVal r1 As Long, ByVal r2 As Long)
    If r1 = r2 Then Exit Sub
    Dim c As Long, t As Variant
    For c = 1 To UBound(a, 2)
        t = a(r1, c): a(r1, c) = a(r2, c): a(r2, c) = t
    Next
End Sub
VB

重要ポイントの深掘り

  • 「比較関数」を独立させると、文字列・数値・日付・自然順などの切替が容易です。
  • クイックソートは速い（平均 O(n log n)）が安定ではないため、同値の元順序が崩れる可能性があります。安定性が必要な場面は次節のマージソートを使いましょう。

安定ソート：マージソートで元順序を保つ

マージソート（2次元配列、キー列指定、昇降切替）

' ModStableMergeSort.bas
Option Explicit

Public Sub MergeSort2D(ByRef a As Variant, ByVal keyCol As Long, ByVal asc As Boolean)
    Dim n As Long: n = UBound(a, 1)
    If n <= 2 Then Exit Sub
    Dim temp As Variant: ReDim temp(1 To n, 1 To UBound(a, 2))

    Dim width As Long: width = 1
    Do While width < n
        Dim i As Long: i = 2 ' ヘッダーを1行目と想定
        Do While i <= n
            Dim left As Long: left = i
            Dim mid As Long: mid = WorksheetFunction.Min(i + width - 1, n)
            Dim right As Long: right = WorksheetFunction.Min(i + 2 * width - 1, n)
            MergeBlocks a, temp, left, mid, right, keyCol, asc
            i = i + 2 * width
        Loop
        ' temp → a に戻す
        Dim r As Long, c As Long
        For r = 2 To n
            For c = 1 To UBound(a, 2)
                a(r, c) = temp(r, c)
            Next
        Next
        width = width * 2
    Loop
End Sub

Private Sub MergeBlocks(ByRef a As Variant, ByRef temp As Variant, _
                        ByVal left As Long, ByVal mid As Long, ByVal right As Long, _
                        ByVal keyCol As Long, ByVal asc As Boolean)
    Dim i As Long: i = left
    Dim j As Long: j = mid + 1
    Dim k As Long: k = left

    Do While i <= mid And j <= right
        If CmpAsc(a(i, keyCol), a(j, keyCol), asc) <= 0 Then
            CopyRow a, i, temp, k: i = i + 1
        Else
            CopyRow a, j, temp, k: j = j + 1
        End If
        k = k + 1
    Loop
    Do While i <= mid: CopyRow a, i, temp, k: i = i + 1: k = k + 1: Loop
    Do While j <= right: CopyRow a, j, temp, k: j = j + 1: k = k + 1: Loop
End Sub

Private Sub CopyRow(ByRef src As Variant, ByVal r As Long, ByRef dst As Variant, ByVal k As Long)
    Dim c As Long
    For c = 1 To UBound(src, 2): dst(k, c) = src(r, c): Next
End Sub

Private Function CmpAsc(ByVal x As Variant, ByVal y As Variant, ByVal asc As Boolean) As Long
    Dim sx As String: sx = LCase$(Trim$(CStr(x)))
    Dim sy As String: sy = LCase$(Trim$(CStr(y)))
    Dim r As Long: If sx < sy Then r = -1 ElseIf sx > sy Then r = 1 Else r = 0
    CmpAsc = IIf(asc, r, -r)
End Function
VB
' 使用例：安定ソートで顧客名（A列）昇順
Public Sub SortStableExample()
    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim a As Variant: a = ws.Range("A1").CurrentRegion.Value
    MergeSort2D a, 1, True
    ws.Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub
VB

重要ポイントの深掘り

  • マージソートは安定（同値の元順序保持）。多列ソートを「後ろのキーから順に安定ソート」すると、安定な複合並べ替えができます。
  • 下から順に「第2キー→第1キー」の順で安定ソートをかけると、結果は「第1キー優先・同値は第2キーで整序」になります。

高速＋原地並べ替え：ヒープソートで大規模に強く

ヒープソート（配列1次元の典型、2次元の行キーも対応）

' ModHeapSort.bas
Option Explicit

Public Sub HeapSort2D(ByRef a As Variant, ByVal keyCol As Long, ByVal asc As Boolean)
    Dim n As Long: n = UBound(a, 1)
    Dim start As Long: start = n \ 2
    Dim endN As Long: endN = n

    ' ヒープ構築
    Dim i As Long
    For i = start To 2 Step -1
        SiftDown a, i, endN, keyCol, asc
    Next

    ' ソート
    For i = endN To 2 Step -1
        SwapRows a, 2, i
        SiftDown a, 2, i - 1, keyCol, asc
    Next
End Sub

Private Sub SiftDown(ByRef a As Variant, ByVal start As Long, ByVal endN As Long, ByVal keyCol As Long, ByVal asc As Boolean)
    Dim root As Long: root = start
    Do While root * 2 <= endN
        Dim child As Long: child = root * 2
        Dim swapI As Long: swapI = root
        If CmpAsc(a(swapI, keyCol), a(child, keyCol), asc) < 0 Then swapI = child
        If child + 1 <= endN Then
            If CmpAsc(a(swapI, keyCol), a(child + 1, keyCol), asc) < 0 Then swapI = child + 1
        End If
        If swapI = root Then
            Exit Do
        Else
            SwapRows a, root, swapI
            root = swapI
        End If
    Loop
End Sub

Private Sub SwapRows(ByRef a As Variant, ByVal r1 As Long, ByVal r2 As Long)
    If r1 = r2 Then Exit Sub
    Dim c As Long, t As Variant
    For c = 1 To UBound(a, 2)
        t = a(r1, c): a(r1, c) = a(r2, c): a(r2, c) = t
    Next
End Sub
VB

重要ポイントの深掘り

  • ヒープソートは原地（追加メモリほぼ不要）で安定でないが、最悪でも O(n log n) の性能を出せるため「データが偏っても急に遅くならない」強みがあります。
  • 大規模でメモリを節約したい場合の選択肢。安定性が不要なら有力です。

実務設計：多列キー・カスタム比較・自然順・数値/日付

多列キーでソート（安定ソートを後ろから）

' ModMultiKeySort.bas
Option Explicit

Public Sub SortByMultiKeysStable(ByVal wsName As String)
    Dim ws As Worksheet: Set ws = Worksheets(wsName)
    Dim a As Variant: a = ws.Range("A1").CurrentRegion.Value
    ' 第3キー（C列）昇順 → 第2キー（B列）降順 → 第1キー（A列）昇順
    MergeSort2D a, 3, True
    MergeSort2D a, 2, False
    MergeSort2D a, 1, True
    ws.Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub
VB

数値比較・日付比較・自然順比較

' 数値比較（空は最小、文字は数値化できれば数値で）
Public Function CmpNumber(ByVal x As Variant, ByVal y As Variant) As Long
    Dim dx As Double: dx = Val(CStr(x))
    Dim dy As Double: dy = Val(CStr(y))
    If dx < dy Then CmpNumber = -1 ElseIf dx > dy Then CmpNumber = 1 Else CmpNumber = 0
End Function

' 日付比較（CDateできるテキスト対応）
Public Function CmpDateVal(ByVal x As Variant, ByVal y As Variant) As Long
    Dim dx As Double: dx = CDbl(CDate(x))
    Dim dy As Double: dy = CDbl(CDate(y))
    If dx < dy Then CmpDateVal = -1 ElseIf dx > dy Then CmpDateVal = 1 Else CmpDateVal = 0
End Function

' 自然順（例：「item2」＜「item10」）
Public Function CmpNatural(ByVal x As Variant, ByVal y As Variant) As Long
    Dim sx As String: sx = LCase$(Trim$(CStr(x)))
    Dim sy As String: sy = LCase$(Trim$(CStr(y)))
    Dim nx As Double: nx = ExtractLastNumber(sx)
    Dim ny As Double: ny = ExtractLastNumber(sy)
    If nx <> ny Then
        CmpNatural = IIf(nx < ny, -1, 1)
    Else
        If sx < sy Then CmpNatural = -1 ElseIf sx > sy Then CmpNatural = 1 Else CmpNatural = 0
    End If
End Function

Private Function ExtractLastNumber(ByVal s As String) As Double
    Dim i As Long, buf As String
    For i = Len(s) To 1 Step -1
        Dim ch As String: ch = Mid$(s, i, 1)
        If ch Like "[0-9]" Then buf = ch & buf ElseIf Len(buf) > 0 Then Exit For
    Next
    ExtractLastNumber = Val(buf)
End Function
VB

重要ポイントの深掘り

  • 比較関数は「正規化（Trim/LCase）→型変換→比較」の流れを固定すると安定します。
  • 自然順は簡易なら「末尾数字」で十分。厳密な自然順が必要なら、文字列を「数字チャンク＋文字チャンク」に分解して比較します。

シート連携テンプレ：範囲指定・ヘッダー保持・見た目整える

ヘッダーを固定してデータ部のみソート

' ModSortRangeUI.bas
Option Explicit

Public Sub SortCurrentRegionByCol(ByVal keyColLetter As String, ByVal asc As Boolean, _
                                  Optional ByVal stable As Boolean = True)
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim a As Variant: a = rg.Value

    Dim keyCol As Long: keyCol = Range(keyColLetter & "1").Column

    If stable Then
        MergeSort2D a, keyCol, asc
    Else
        QuickSort2D a, 2, UBound(a, 1), keyCol, asc, 0
    End If

    rg.Value = a
    rg.Columns.AutoFit
    ' 条件付き書式やテーブルは事前に解除/再適用の設計も検討
End Sub
VB

重要ポイントの深掘り

  • CurrentRegionで「連続データ」を一発取得。ヘッダーを1行目前提にしてデータ部のみ並べ替えます。
  • テーブル（ListObject）を使っている場合は、テーブルの並べ替え機能でも可。ただし複雑なカスタム比較は配列ソートが柔軟です。

落とし穴と対策（深掘り）

安定性が必要なのに不安定ソートを使う

同値の順序が意味を持つ（タイブレーク、時系列保持など）なら、必ず安定ソート（マージ）を選択。

型混在・文字数値の比較誤差

数値は数値で比較（Val/CDbl）。文字列の“数値らしさ”で比較すると、”2″と”10″の順序が崩れます。自然順比較へ切替。

正規化の不足

Trimや大小統一を入口で固定。日本語は全半角統一が必要なら前処理関数を挟む。正規化が揺れると順序が不安定になります。

行の入れ替えミス

2次元配列のSwapは「全列」入れ替え必須。キー列だけ入れ替えると表が壊れます。

まとめ：配列I/O＋適切なアルゴリズム＋比較関数の設計で“思い通りの並べ替え”

  • まず配列に読み出して、クイック（速い・不安定）、マージ（安定）、ヒープ（原地・最悪でも速い）を用途で使い分け。
  • 比較関数で文字/数値/日付/自然順を切替え、正規化を入口で固定。
  • 多列キーは「後ろから安定ソート」で簡潔に。最後に一括書き戻して仕上げる。

スポンサーリンク
タイトルとURLをコピーしました