このサイトはCocoonを使っています。現在「ミックスブルー [作者: y.hiroaki氏]」スキンを適用中です(^^)/

【Excel VBA】ファイルを開いてデータを取得する(その2)

スポンサーリンク

ファイルを開いてデータを取得する(その1)ではApplicationオブジェクトのGetOpenFilenameメソッドを使って、ファイルを選択して開く処理を紹介しました
今回は、ApplicationオブジェクトのFileDialog(msoFileDialogFolderPicker)メソッドを使います。日常業務の定型的な作業では、決まったフォルダに決められたファイルが保存されている場合が多いのではないでしょうか。そういった場合には、今回紹介する方法のほうがより効率的かなと思います
では今回も、「いつも汎用でだれでも使えて活用できるように考えてvbaを使う」というポリシーで書いていこうと思います

2回目は前回の続き(その2)でフォルダを指定する方法から紹介

・指定フォルダ内のファイルをすべて開いてデータを取得する
・これらの作業を自動化するにはこんな感じで作業をつなぐ
・汎用で使えるように考えるとこんな感じ

スポンサーリンク

指定フォルダ内のファイルをすべて開いてデータを取得する

フォルダを指定する方法

ApplicationオブジェクトのFileDialog(msoFileDialogFolderPicker)メソッドで選択ダイアログを表示させて、選択したフォルダのフルパスを取得(セルA1に書き出し)

Sub selectFolder()
    Dim strFolder As String
    Dim dlg As FileDialog
    
    'フォルダー選択ダイアログを表示
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    ' キャンセルボタンクリック時はそのまま終了
    If dlg.Show = False Then Exit Sub
    'フォルダーのフルパスを変数に格納
    strFolder = dlg.SelectedItems(1)
    'セルに書き出し
    Range("A1").Formula = strFolder
    Set dlg = Nothing
End Sub

フォルダ内のファイル名を取得

・指定フォルダ内のExcelファイルをDir関数ですべて取得

'フォルダ内のファイル名を取出して、セルに反映する
Sub GetFileName_Set()
    Dim strFolder   As String  'フォルダー名
    Dim strFilename As String  'ファイル名
    Dim nRange      As Long    '行カウンタ
    Dim strFileType As String  'ファイル形式
    
    strFileType = "*.xls*"  'ファイル形式を指定
    Range("A2:A1000").Clear '書き込むセル範囲を空ける
    strFolder = Range("A1") & "\"  '検索するフォルダー"\"="¥"
    
    strFilename = Dir(strFolder & strFileType) '最初のファイル名
    'ファイルが見つからなくなるまでループしてデータをセットする
    nRange = 2  '2行目からセット
    Do While strFilename <> ""   ' ループを開始します。
        'セルにファイル名をセットする(拡張子付きのまま)
        If strFilename <> "" Then
            Cells(nRange, 1) = strFilename
            nRange = nRange + 1 'カウントアップ
        End If
        strFilename = Dir   '次のファイル名を返す
    Loop
End Sub

ファイルを開いてデータを抜き出す処理

・セルに書き出したファイル名のブックを順番に開いてデータを取得
・(その1)で使ったコードを流用して加工
・セルに書き出したファイル名を配列に格納して使う

'別ブックからデータ取得(複数ファイルの選択可能で処理する)
Sub Open_Files_DataFetch()
    Dim selectFileName As Variant
    Dim OpenFileName As Variant
    Dim xls As New Excel.Application '新規にExcelを起動
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim Mysh As Worksheet
    Dim shData As Variant
    Dim n As Long
    Dim strFolder As String
    
    On Error GoTo ErrHandler
    Set Mysh = ThisWorkbook.ActiveSheet
    With Mysh
        n = 1
        '取得する情報の見出しを列先頭に記入
        .Cells(n, 2).Value = "ファイル名"
        .Cells(n, 3).Value = "シート名"
        .Cells(n, 4).Value = "取得したデータ"
        'ファイル名をセル範囲から取得して配列に格納
        selectFileName = Range(Range("A2"), Range("A2").End(xlDown))
        strFolder = Range("A1").Value & "\"
        '選択されたファイルに対する処理
        If IsArray(selectFileName) Then
    '        On Error Resume Next  '実行時エラー対策
            '全てのファイルに繰り返し処理を行う
            For Each OpenFileName In selectFileName
                OpenFileName = strFolder & OpenFileName
                'ファイル(ブック)をリードオンリーで開く
                Set wb = xls.Workbooks.Open(fileName:=OpenFileName, _
                                            UpdateLinks:=0, ReadOnly:=True)
                'シートはshに
                Set sh = wb.Worksheets(1) 'シート名を指定する場合()内に記述
    '//////////ここに開いた別ブックからデータを取得する処理を入れる//////////
                '開いた別ブックのデータを変数に保存
                shData = sh.Range("A3").Value
                '変数のデータを書き込む
                n = n + 1
                .Cells(n, 1).Value = wb.name    'ファイル名
                .Cells(n, 2).Value = sh.name    'シート名
                .Cells(n, 3).Value = shData     'セルのデータ
    '//////////ここまで開いた別ブックからデータを取得する処理を//////////////
                wb.Close savechanges:=False         '開いたファイルを閉じる
            Next
        Else
            MsgBox ("ファイルの指定がありません!終了します")
            Exit Sub
        End If
    End With
    MsgBox "選択したファイルの処理が終了しました", vbOKOnly + vbInformation, "ファイル一括処理"
    xls.Application.Quit
    Set xls = Nothing
    Exit Sub
ErrHandler:
    MsgBox "「" & OpenFileName & "」の処理中にエラーが発生しました" & vbCrLf & _
                                Err.Description, vbExclamation, "ファイル一括処理"
    xls.Application.Quit
    Set xls = Nothing
End Sub

これらの作業を自動化するにはこんな感じで作業をつなぐ

・この3つのモジュールを順番に実行すれば(その1)と同じ結果が得られます
・シートにボタンを配置してマクロを登録して実行するなど
次のようなコードを書いて実行させればワンクリックですべて実行できます

Sub Test()
    Call selectFolder
    Call GetFileName_Set
    Call Open_Files_DataFetch
End Sub

「Test」実行でそれぞれの作業(モジュール)をつなげて連続実行するということ

汎用で使えるように考えるとこんな感じ

Sub selectionFolder()
    Dim strFolder As String
    strFolder = getFolder()  'フォルダーの選択関数を呼ぶ
    Range("A1").Value = strFolder
End Sub
'フォルダー選択ダイアログを表示する関数
Function getFolder() As String
    Dim dlg As FileDialog
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    ' キャンセルボタンクリック時
    If dlg.Show = False Then        
        getFolde = ""
        Exit Function
    End If
    ' フォルダーのフルパスをgetFolderに格納
    getFolder = dlg.SelectedItems(1) 
    Set dlg = Nothing    
End Function

フォルダ選択ダイアログの関数化(Functionプロシージャ)で汎用化
・違う作業でもこの関数を使えばフォルダを簡単に選択(指定)できます

次回は
‘//////////ここに開いた別ブックからデータを取得する処理を入れる//////////
この部分の汎用的な使い方を考えていきたいと思います。ご期待ください!

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

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