【Excel VBA】別ブックからデータを抜き出す処理（その２）

'開いた別ブックから指定セルのデータを抜き出す処理
Sub TargeCellsPullOut()
    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列右の列番号
    
    On Error GoTo er
    '一応フォルダの存在チェック
    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 'マクロをスタートしたシート
    With mainSh
        Set gatSh = myWb.Worksheets(arr(5)) '5【データ集計用シート名】
        Application.ScreenUpdating = False
        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
            'ファイルをリードオンリーで開く
            Set tgWb = Workbooks.Open(fileName:=tgFPN, ReadOnly:=True)            
            ReDim db(tgCellCount) As Variant    '配列要素数をセット
            db(0) = tgFName & "_" & arr(6)   '先頭にファイル名+シート名付加'6【その他の設定】
            For h = 1 To tgCellCount            'ターゲットセルからデータ取得
                tgAd = .Cells(h, colT).Formula  'アドレス値代入
                db(h) = Worksheets(arr(6)).Range(tgAd).Value '6【その他の設定】
            Next
            tRow = tRow + 1 '最終行の下（1行下げる）
            With gatSh                          '配列を一括で貼り付ける
                .Range(.Cells(tRow, 1), .Cells(tRow, tgCellCount + 1)).Value = db
                .Range(.Cells(tRow, 1), .Cells(tRow, tgCellCount + 1)).WrapText = False
            End With
            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, "データ取得"
    Exit Sub
er:
'エラー処理
    Msg = "ｴﾗｰ番号 " & Str(Err.Number) & " " & Err.Source & _
          " でｴﾗｰが発生しました。" & Chr(13) & Err.Description
    MsgBox Msg, , "ｴﾗｰ", Err.HelpFile, Err.HelpContext
    Application.ScreenUpdating = True
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:=i & "【*】")
            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