【ExcelVBA】配列とMatchでデータ抽出、Findで設定

'開いた別ブックから目的のデータを抜き出す処理
Sub TargeDataPullOut()
    Dim FCell As Range
    Dim tRow As Long, h As Long, i As Long
    Dim res As Long, n As Long
    Dim tgFCount As Long
    Dim tgCellCount As Long
    Dim tgFName As String, tgFPN As String
    Dim Msg As String
    Dim tgAd As String
    Dim db As Variant
    Dim myWb As Workbook, tgWb As Workbook
    Dim mainSh As Worksheet, tgSh As Worksheet
    Dim gatSh As Worksheet
    Dim colF As Long, rowF As Long, colT As Long
    Dim arr() As Variant
    
    '設定数を取得
    n = Application.CountIf(Cells, "*【*】")
    '設定取得へ
    arr() = Setting(n)
    '2【フォルダ内ファイル名】行列取得
    colF = Range(arr(2)).Column     '列番番号
    rowF = Range(arr(2)).Row        '行番号
    '3【Targetの設定用符号】'Target番地の列位置
    colT = Range(arr(3)).Column + 1 '3列右の列番号
    '一応フォルダの存在チェック
    If Dir(arr(1), vbDirectory) = "" Then   '1【フォルダPATH】
        res = MsgBox("フォルダ設定に誤りがあります。" & _
                        "確認後に再実行してください。", vbYes, _
                        "データ集計"): Exit Sub
    End If
    'フォルダ名の末尾に\がある場合削除（ルートかどうか判別）
    If Right(arr(1), 1) = "\" Then arr(1) = Left(arr(1), (Len(arr(1)) - 1))
    Set myWb = ThisWorkbook
    Set mainSh = myWb.ActiveSheet 'マクロをスタートしたシート
    Set gatSh = myWb.Worksheets(arr(5)) '5【データ集計用シート名】
    Application.ScreenUpdating = False
    With mainSh
        i = 1 'ループカウンターセット
        If rowF >= 2 Then rowF = rowF - i
        '対象ファイル数をカウント
        tgFCount = WorksheetFunction.CountA(.Columns(colF)) - rowF
        '貼付け先シートのデータ入力行を調べる
        tRow = gatSh.Cells(Rows.Count, 1).End(xlUp).Row
        'Targetセル数をカウント
        tgCellCount = WorksheetFunction.CountA(.Columns(colT))
        Do Until i > tgFCount 'ループ開始
            tgFName = .Cells(rowF + i, colF) '読み込むファイル名をセット
            tgFPN = arr(1) & "\" & tgFName    'フルパスのファイル名
            If Dir(tgFPN) = "" Then
                res = MsgBox(tgFPN & " は存在しません。" & _
                        "このファイルを飛ばして続行しますか。", _
                        vbYesNo, "データ集計")
                If res = vbYes Then
                    GoTo nextloop
                Else
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
            End If
            On Error Resume Next  '実行時エラー対策
            'ファイルをリードオンリーで開く
            Set tgWb = Workbooks.Open(fileName:=tgFPN, ReadOnly:=True)
            'データ抜き出し処理へ
            Call index_match2(tgWb, arr)
            'ファイルを閉じる
            Workbooks(tgFName).Close savechanges:=False
nextloop:
            i = i + 1
        Loop
        gatSh.Activate
        ActiveWindow.Visible = True
        Range("a1").Select
    End With
    Application.ScreenUpdating = True
    MsgBox "データの取得が完了しました", vbOKOnly, "データ取得"
End Sub

'シートに書き出した設定の情報を取得する
Function Setting(n As Long) As Variant
    Dim FCell As Range
    Dim myWb As Workbook
    Dim mainSh As Worksheet
    Dim arr() As Variant
    Dim i As Long
    
    ReDim arr(1 To n) As Variant
    Application.ScreenUpdating = False
    Set myWb = ThisWorkbook
    Set mainSh = myWb.ActiveSheet
    With mainSh
        '設定取得
        For i = 1 To n
            Set FCell = .Cells.Find(What:=Format(i, "00") & "【*】")
            If i = 2 Or i = 3 Then
                arr(i) = FCell.Offset(0, 1).Address
            Else
                arr(i) = FCell.Offset(0, 1)
            End If
        Next
    End With
    Setting = arr()
    Application.ScreenUpdating = True
End Function

'データ取得処理（配列）
Sub index_match2(wb As Workbook, ar As Variant)
    'ar(5) = 05【データ集計用シート名】
    'ar(6) = 06【Targetシート名】
    'ar(7) = 07【ID設定列】         'ar(12) = 12【TargetID設定列】
    'ar(8) = 08【名称列】           'ar(13) = 13【Target名称列】
    'ar(9) = 09【DATE開始行】       'ar(14) = 14【TargetDATE開始行】
    'ar(10) = 10【取得範囲開始列】  'ar(15) = 15【Target範囲開始列】
    'ar(11) = 11【取得範囲最終列】  'ar(16) = 16【Target範囲最終列】
    Dim workSh, tgetSh, mySh As Worksheet
    Set mySh = ThisWorkbook.ActiveSheet
    Set workSh = ThisWorkbook.Worksheets(ar(5)) '05【データ集計用シート名】
    Set tgetSh = wb.Worksheets(ar(6)) '06【Targetシート名】
    Dim wShEndR As Long, tShEndR As Long    '最終行保存用
    Dim tmpStr As String                    '検索対象ID保存用
    wShEndR = workSh.Cells(Rows.Count, ar(7)).End(xlUp).Row
    tShEndR = tgetSh.Cells(Rows.Count, ar(12)).End(xlUp).Row
    'Matchで検索する範囲とFindで返答する範囲指定用変数
    Dim tgetRng As Range    'ターゲットID用
    Dim aggRng As Range     '集約シートID用
    Dim matchRng As Long    '検索ID位置
    Dim vSpRng As Variant   '指定範囲のデータ配列
    Dim MyArray As Variant  '取得配列保存用
    Dim tgetTmpR As Long, l As Long 'ループカウンター用
    
    'オートフィルターがセットされていたら解除
    If workSh.AutoFilterMode = True Then workSh.Range("A1").AutoFilter
    If tgetSh.AutoFilterMode = True Then tgetSh.Range("A1").AutoFilter
    
    'TargetシートのIDをセット
    Set tgetRng = tgetSh.Range(tgetSh.Cells(ar(14), ar(12)), tgetSh.Cells(tShEndR, ar(12)))
    '貼り付け先シートのIDをセット
    Set aggRng = workSh.Range(workSh.Cells(ar(9), ar(7)), workSh.Cells(wShEndR, ar(7)))
    'Targetの対象範囲を配列に入れる
    vSpRng = tgetSh.Range(tgetSh.Cells(ar(14), ar(15)), tgetSh.Cells(tShEndR, ar(16)))

    '発見できなかった場合エラーとなりマクロが停止するので、On Errorステートメントで制御する
    On Error Resume Next
    Application.CutCopyMode = False
    '実際の処理
    '貼り付け先の配列をいったん初期化してセット
    ReDim MyArray(UBound(vSpRng, 1), UBound(vSpRng, 2)) As Variant
    For tgetTmpR = LBound(vSpRng, 1) To UBound(vSpRng, 1) 'データ行分をループ
        tmpStr = tgetRng(tgetTmpR).Value  '検索対象ID
        '対象IDの位置を検索
        matchRng = Application.WorksheetFunction.Match(tmpStr, aggRng, 0)
        If matchRng <> "" Then
            For l = 1 To ar(16) - ar(15) + 1 '[最終列]-[範囲開始列]+1
                'MyArrayは(0～、0～)なので「1」マイナス
                MyArray(0, l - 1) = vSpRng(tgetTmpR, l) '指定行のセルデータを配列に代入
            Next
            With workSh
                matchRng = matchRng + ar(9) - 1
                .Range(.Cells(matchRng, ar(10)), .Cells(matchRng, ar(11))) = MyArray '配列を貼付
                .Range(.Cells(matchRng, ar(11) + 1), .Cells(matchRng, ar(11) + 1)) = Now '最終列の次に日時
            End With
        End If
    Next
    Erase MyArray   '配列初期化
    Erase vSpRng
    Application.CutCopyMode = True
End Sub