【VBA】重複データを配列を使って高速に抽出する方法

Option Explicit
Sub ExtractDuplicateData()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' データの最終行を取得
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 配列にデータを読み込む
    Dim data() As Variant
    data = ws.Range("A2:A" & lastRow)
    
    ' 重複チェック用の配列を作成
    Dim checkArray() As Boolean
    ReDim checkArray(1 To UBound(data, 1))
    
    ' 配列をソートする（必要に応じてカスタマイズ可能）
    Call QuickSort(data, 1, UBound(data, 1))
    
    Dim i As Long
    For i = LBound(data, 1) To UBound(data, 1)
        If data(i, 1) <> vbNullString And (i > LBound(data, 1) And data(i, 1) = data(i - 1, 1)) Then
            ' 重複データを抽出
            ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = data(i, 1)
        End If
    Next i
    
    MsgBox "重複データの抽出が完了しました。", vbInformation
End Sub

' クイックソート関数（配列を昇順に並び替え）
Sub QuickSort(ByRef arr() As Variant, ByVal low As Long, ByVal high As Long)
    Dim pivot As Variant
    Dim i As Long, j As Long
    
    If low < high Then
        pivot = arr((low + high) \ 2, 1)
        i = low - 1
        j = high + 1
        Do While True
            Do
                i = i + 1
            Loop Until arr(i, 1) >= pivot
            Do
                j = j - 1
            Loop Until arr(j, 1) <= pivot
            If i < j Then
                Call Swap(arr, i, j)
            Else
                Exit Do
            End If
        Loop
        
        ' 再帰呼び出し
        Call QuickSort(arr, low, j)
        Call QuickSort(arr, j + 1, high)
    End If
End Sub

' スワップ関数（配列の要素を交換）
Sub Swap(ByRef arr() As Variant, ByVal i As Long, ByVal j As Long)
    Dim temp As Variant
    temp = arr(i, 1)
    arr(i, 1) = arr(j, 1)
    arr(j, 1) = temp
End Sub