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

ページコンテンツ

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

一貫性のある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

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

ダウンロード

当サイトの免責事項をお読みになってからお使いください。

フォイル値取得ツール 119.03 KB

Download

ファイルやコードの利用について

サンプルコードなどは当サイトの免責事項をよくお読みになってからお使いください。

Twitterフォロー

ブログの更新通知を受け取るにはこちらにはこちら↓Twitterもやってます(^^♪Excelについてはあまり触れませんがブログの更新のお知らせはツイートしています(^^♪

Twitterフォロー

Follow @takabou63

キーワード検索

カテゴリーで絞る

月で探す

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