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

Option Explicit
Sub CopyDuplicateData()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim arrData() As Variant, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False '画面更新を停止
    Set wsSource = ThisWorkbook.Sheets("Sheet1") 'ソースシート名を指定
    Set wsTarget = ThisWorkbook.Sheets("Sheet2") 'ターゲットシート名を指定
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row 'データの最終行取得
    ReDim arrData(1 To lastRow, 1 To 1) '配列の初期化
    For i = 2 To lastRow 'データを読み込み
        If Not dict.exists(wsSource.Cells(i, 1)) Then '重複チェック
            dict.Add wsSource.Cells(i, 1), Nothing '辞書に追加
        Else
            arrData(dict.Count + 1, 1) = wsSource.Cells(i, 1) '重複データを配列に格納
        End If
    Next i
    ReDim Preserve arrData(1 To dict.Count, 1 To 1)
    For j = LBound(arrData) To UBound(arrData) 'ターゲットシートへのコピー
        wsTarget.Cells(j + 1, 1).Value = arrData(j + 1, 1)
    Next j
    Application.ScreenUpdating = True '画面更新を再開
End Sub