【VBA】重複データを配列を使って高速に別ブックとして保存する方法

Option Explicit
Sub SaveDuplicateDataToNewWorkbook()
    Dim ws As Worksheet, wb As Workbook, newWb As Workbook
    Dim lastRow As Long, i As Long
    Dim dataRange As Range
    Dim dataArray() As Variant
    Dim duplicateArray() As Variant
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' シートと最終行を設定
    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    Set dataRange = ws.Range("A2:A" & lastRow)
    
    ' データ配列に読み込み
    dataArray = dataRange.Value
    
    ' 重複データの抽出
    ReDim duplicateArray(1 To UBound(dataArray, 1), 1 To 1)
    For i = LBound(dataArray, 1) To UBound(dataArray, 1)
        If Not dict.exists(dataArray(i, 1)) Then
            dict.Add dataArray(i, 1), Nothing
        Else
            duplicateArray(dict.Count + 1, 1) = dataArray(i, 1)
        End If
    Next i
    
    ' 新規ワークブックの作成とデータの書き込み
    Set newWb = Workbooks.Add
    With newWb.Sheets(1)
        .Cells(1, 1).Value = "重複データ"
        .Range("A2:A" & dict.Count + 1) = Application.Transpose(duplicateArray)
    End With
    
    ' 新規ワークブックを保存するかどうかの確認ダイアログを表示しないように設定
    newWb.DisplayAlerts = False
    newWb.SaveAs ThisWorkbook.Path & "\DuplicateData.xlsx"
    newWb.Close SaveChanges:=True
    
    ' 画面更新停止解除と辞書オブジェクトの解放
    Application.ScreenUpdating = True
    Set dict = Nothing
End Sub