【Excel VBA】大量データからマッチングデータを抽出

Sub マクロ開始()
    With Application
        .ScreenUpdating = False            '画面描画を停止
        .EnableEvents = False              'イベントを抑止
        .DisplayAlerts = False             '確認メッセージを抑止
        .Calculation = xlCalculationManual '計算を手動に
        '.Cursor = xlWait
    End With
End Sub

Sub マクロ終了()
    With Application
        '.StatusBar = False                   'ステータスバーを消す
        .Calculation = xlCalculationAutomatic '計算を自動に
        .DisplayAlerts = True                '確認メッセージを開始
        .EnableEvents = True                 'イベントを開始
        .ScreenUpdating = True             　'画面描画を開始
        '.Cursor = xlDefault    
    End With
End Sub

'貼付け元シート上で開始すること
Sub Array_match()
    Dim workSh As Worksheet, prefSh As Worksheet
    Dim sName As String
    Set prefSh = ThisWorkbook.ActiveSheet
    sName = prefSh.Range("K1").Value '取得データ貼付け先シート名
    Set workSh = ThisWorkbook.Worksheets(sName)
    Dim ptCol As Long, pFlgCol As Long
    Dim pMCol As Long, pCol() As Long
    Dim wtCol As Long, wFlgCol As Long
    Dim wMCol As Long, wCol() As Long
    Dim pRow As Long, wRow As Long
    Dim i As Long
    
    '▼マーク（ターゲット）列を検索
    ptCol = Application.WorksheetFunction.Match("▼", prefSh.Rows(2), 0)
    wtCol = Application.WorksheetFunction.Match("▼", workSh.Rows(2), 0)
    '設定行の最大数
    pMCol = Application.WorksheetFunction.Max(prefSh.Rows(2))
    wMCol = Application.WorksheetFunction.Max(workSh.Rows(2))
    'データ開始列の設定
    pRow = prefSh.Range("G1")
    wRow = workSh.Range("G1")
    '設定の不整合を判定する処理
    If pMCol <> wMCol Then
        MsgBox "引き当てる列の数が不整合のため中止します！"
        Exit Sub
    End If
    ReDim pCol(1 To pMCol)  '指定列の指定を代入する
    pFlgCol = 0 '指定列の配置が連続しているかどうか調べる「0」は連続
    For i = 1 To pMCol
        pCol(i) = Application.WorksheetFunction.Match(i, prefSh.Rows(2), 0)
        If i > 1 Then
            If pCol(i) <> pCol(i - 1) + 1 Then pFlgCol = 1 '不連続は「1」
        End If
    Next
    ReDim wCol(1 To wMCol)  '貼付け先も同様に調べる
    wFlgCol = 0
    For i = 1 To wMCol
        wCol(i) = Application.WorksheetFunction.Match(i, workSh.Rows(2), 0)
        If i > 1 Then
            If wCol(i) <> wCol(i - 1) + 1 Then wFlgCol = 1 '不連続は「1」
        End If
    Next
    Dim workShEndR As Long, prefShEndR As Long
    Dim tgetTmpR As Long, tmpStr As Variant '文字列の場合もあるのでVariantで
    '最終行取得
    workShEndR = workSh.Cells(Rows.Count, wtCol).End(xlUp).Row
    prefShEndR = prefSh.Cells(Rows.Count, ptCol).End(xlUp).Row
    Dim tgetRng As Range
    'ターゲット（ID）の列範囲をセット
    Set tgetRng = Range(prefSh.Cells(pRow, ptCol), prefSh.Cells(prefShEndR, ptCol))
    Dim matchRng As Variant
    Dim MyArray() As Variant

    'スピードアップのため動作を制限する
    Call マクロ開始

    'オートフィルタが設定されていたら解除する
    If (workSh.AutoFilterMode = True) Then workSh.Rows(wRow - 1).AutoFilter
    'ターゲットID件数分のループ
    For tgetTmpR = wRow To workShEndR
       DoEvents		'途中で中断ができるように
       tmpStr = workSh.Cells(tgetTmpR, wtCol).Value '検索対象ID
        '発見できなかった場合エラーとなりマクロが停止するので制御する
        On Error Resume Next
        '対象IDコードを配列から検索
        matchRng = Application.WorksheetFunction.Match(tmpStr, tgetRng, 0)
        If Err <> 0 Then
            matchRng = "" 'ERRORの場合空白に
            Err.Clear
        End If
        If matchRng = "" Then
            '何もしない
        Else
            matchRng = matchRng + wRow - 1 '開始行分をプラス -1
            '配列のメモリ領域割り当て
            ReDim MyArray(1 To pMCol)
            If pFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To pMCol
                    MyArray(i) = prefSh.Cells(matchRng, pCol(i)).Value
                Next
            Else
                MyArray() = prefSh.Range(prefSh.Cells(matchRng, pCol(1)), _
                                    prefSh.Cells(matchRng, pCol(pMCol))).Value
            End If
            If wFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To wMCol
                    workSh.Cells(tgetTmpR, wCol(i)).Value = MyArray(i)
                Next
            Else
                workSh.Range(workSh.Cells(tgetTmpR, wCol(1)), _
                                workSh.Cells(tgetTmpR, wCol(pMCol))) = MyArray
            End If
            Erase MyArray
        End If
    Next

    '動作制限を解除
　  Call マクロ終了

    MsgBox "引当て入力が完了しました！"
End Sub