一貫性のあるBookの値を取得するツールを作ってみた

1 一貫性のあるBookの値を取得するツールを作ってみた

この記事を書いた人
最新の記事

taka

あることがキッカケでVBAを独学で勉強しました、今ではブログを通してVBAでできることを解説しつつ、VBAや他の言語の勉強、ブログ運営の勉強をしています(^^♪

一貫性のあるBookの値を取得するツールを作ってみた

どうも、taka です( ^ω^ )今回はちょっと仕事で少し必要だったので作成した物をご紹介します(笑)

タイトルを見るとよくわからないとは思うのですが、先日仕事で同じフォーマットでExcel作られたファイルの中身がファイル名と間違っていないか(ファイル名が12月なのに11月の帳票など)を調べてほしいということで・・・

ファイル数は450ほど(;^ω^)こんなの一つ一つ調べることなんてできるわけがないのでツールを作成することにした次第です(;´･ω･)

まぁこんな特殊な経験する方は少ないと思いますが(笑)

ツールの内容

今回のツールの内容としては【フォルダー内のサブフォルダーの中のExcelファイルの値を抽出する】というものです(´・ω・`)

※もう一度言いますが【今回はサブフォルダーの中にあるExcelファイルの中身を取得する】です。フォルダー直下にあるファイルは取得しませんご注意ください。

コードはこんな感じになっています・・・汚いコードで申し訳ないです(/ω＼)

一応ダウンロードファイルを用意しました(;^ω^)

※このコードは超テキトーに作成したので参考程度にしておいてください(;^ω^)

Sub Sample()
    Dim ofdFD As Office.FileDialog
    Dim objFS As New FileSystemObject
    Dim strPath As String
    Dim FName As String
    Dim cnt As Long
   
   strPath = ThisWorkbook.Path 'このVBAコードのあるファイルのパスを指定
    Set ofdFD = Application.FileDialog(msoFileDialogFolderPicker)
    With ofdFD 'ダイヤログボックスの設定
        'ダイヤログボックスのファイル表示の設定
        .InitialView = msoFileDialogViewDetails
        '複数選択をしないよう設定
        .AllowMultiSelect = False
    End With
   
   Application.ScreenUpdating = False '画面更新を非表示にする
   Application.DisplayAlerts = False '警告文を非表示にする
   
   If ofdFD.Show() = -1 Then  'OKや参照・開くなどを押すと返り値【-1】が返ってくる
    Set getf = objFS.GetFolder(ofdFD.SelectedItems(1))
    DoEvents
 For Each fl In getf.SubFolders ' フォルダ一覧を取得
   cnt = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
   ChDir fl.Path
   FName = Dir("*.xls")
   
   Do While FName <> ""
        Workbooks.Open FName '対象ファイルを開く
        ThisWorkbook.Sheets(1).Cells(cnt, 2) = FName 'ファイル名
        ThisWorkbook.Sheets(1).Cells(cnt, 1) = Sheets(1).Cells(1, 1).Value '取得したいセルの位置
        ThisWorkbook.Sheets(1).Cells(cnt, 3) = fl '対象ファイルがあるフォルダー
        cnt = cnt + 1
        ActiveWorkbook.Close '対象ファイルを閉じる
        FName = Dir()
  Loop '繰り返す
Next fl
 
     Else
       MsgBox "キャンセルが押されました"
    End If


    Set ofdFD = Nothing
Application.DisplayAlerts = True  '警告文を表示する

Application.ScreenUpdating = True '画面更新表示する




End Sub