本ページには広告が含まれています。

【Excel VBA】別ブックからデータを抜き出す処理(その2)

Excel VBA 別ブックからデータを抜き出す処理(その2)

(その1)で「設定したターゲットのセル番地をFindメソッドで取得」しましたが、今回は「取得したターゲットセル番地」を使って、実際に別ブックを開いてデータを取り出し、保存先シートに貼り付ける部分を具体的に書いていきます
「Findメソッド」と「配列」を使って素早く取り出していく処理です
「汎用でだれでも使えて活用できるように考えてVBAを使う」というポリシーで書いていきます

表になっていない定型様式のデータを集計シートに表形式で抜き出す処理

・書き出したターゲットのセル番地を使ってデータを抜き出す
・メインの設定シートをもっと汎用で使えるように変更
・ここまでのまとめ

スポンサーリンク

書き出したターゲットのセル番地を使ってデータを抜き出す

VBAコードはこれです。少し長くなってしまいました(^^)
設定を取得する処理を「Functionプロシージャ」にしています
Findメソッドで検索して配列に格納してデータを引き渡しています

'開いた別ブックから指定セルのデータを抜き出す処理
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

【補足説明】
抜き出したデータは配列にすべて保存してから一気に保存先のシートに書き出しています。データを貼り付ける保存先のシートにすでにデータがある場合、その1行下に貼り付けますので、あらかじめ見出しを書き出しておくとよいと思います

メインの設定シートをもっと汎用で使えるように変更

前回のシート(変更前)

変更前の設定シート

変更後のシート(設定をルール付け)

設定をルール付けした変更後のシート

【変更箇所と変更理由】
・設定名を、”NO【*】”のように、番号【名前】としました
・こうすることで”NO【*】”を使ってループ処理と配列が使える
・すべて設定したセルの右側のセルにデータを入れる(値を取得)
・2番と3番は、ループ処理でデータを使うため右側セルのアドレスを取得
前回と比べ汎用性が少し向上したと思う

ここまでの「まとめ」

今までの記事内容を整理します
・別ファイルを保存しているフォルダを指定
・フォルダ内のファイル名を取得
・ターゲットのデータを取り出すための設定
・取り出したデータ(フォルダ名・ファイル名・ターゲットアドレス)
 を使って実際に別ブックからデータを取り出す

次回は、別ブックやCSVファイルからデータを一括で取り出す作業の効率化を行っていきたいと思います。是非ご期待ください!

スポンサーリンク
スポンサーリンク

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しました
こちらからご利用ください