Excelで同一フォルダ内に複数ファイルがあり、すべてのファイルのあるシートに日付を入力する処理をVBAで実現しようとしたのですが、プログラムを紹介しているサイトがなくて、苦労しました。
自分の忘備録も兼ねてまとめます。
同一フォルダ内にある全ファイルのあるシートに日付を入力するプログラム
今回の条件としては、あるフォルダの中に複数ファイルがあり、すべてのファイルのあるシートに同じ日付を入力します。
いつも手作業でやっていたのですが、ファイルを開いて日付を入れて上書きして終了するのを1個1個やっていると面倒になったのでVBA化しました。
なお、同一フォルダ内にあるファイルは2通りあり、日付入力セルが異なります。
また、ファイル名としては4種類あり、それぞれファイル名にA、B、Ｃ、Ｄと識別子がついています。
イメージとしてはフォルダ内は以下のような状態です。
A001-2.xlxs
B001-1.xlxs
B001-2.xlxs
C001-1.xlxs
C001-2.xlxs
D001-1.xlxs
D001-2.xlxs
それぞれＡ、ＢとＣ、Ｄは形式が同じですが、日付を入れたいセルがA、ＢはセルB3、Ｃ、ＤはセルC3とずれているパターンです。
処理に関する説明はコメントを付けているので、そちらを参考にしてください。
なおプログラムの前提としては、操作したいファイルではなくて、ＶＢＡを実行するxlsmファイルを別に作っています。また、xlsmファイル中にプログラム起動のためのボタンを配置し、入れたい日付は同xlsmファイルのシートに入力した状態にしてあります。
Option Explicit
Dim d As String '日付用変数
Dim fldpath As String 'フォルダパス用変数
Dim bookcount As Integer 'ブック数カウント用変数
Sub dateChange()
Dim fld As Object 'フォルダ用変数
Dim fl As Object 'ファイル用変数
Dim fso As Object 'ファイルシステムオブジェクト変数用
Dim file_name As String 'ファイル名用変数
Dim wb As Workbook 'ワークブック用変数
Application.ScreenUpdating = False '画面描画抑止
'変更日付をセルから取得
ThisWorkbook.Worksheets("マクロ").Activate '現在アクティブなブックのシートを指定
d = Range("C4").Value 'マクロシートからセルC4のデータを日付として取得
If d = "" Then '日付未入力チェック
MsgBox "日付が入力されていません。終了します。"
Exit Sub 'プログラム終了
End If
Call getFolderName 'getFolderメソッド呼び出し 変数fldpathに操作しているフォルダ名を入れておく
'ファイルシステムオブジェクトを使用し、フォルダとファイルの操作をする(for each用)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.getFolder(fldpath)
'指定したフォルダの中にあるファイルの数分だけループ
For Each fl In fld.Files
file_name = fl.Name
If file_name <> ThisWorkbook.Name Then
Workbooks.Open Filename:=file_name, UpdateLinks:=0
If Mid(file_name, 2, 1) = "A" Or Mid(file_name, 2, 1) = "B" Then
ActiveWorkbook.Worksheets(3).Range("B3").Value = d
ElseIf Mid(file_name, 2, 1) = "C" Or Mid(file_name, 2, 1) = "D" Then
ActiveWorkbook.Worksheets(3).Range("C3").Value = d
Else
ActiveWorkbook.Worksheets(1).Range("B3").Value = d
End If
ActiveWorkbook.Close True
End If
Next fl
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub getFolderName() '処理するフォルダを確定するためのフォルダ名取得用関数
Dim bookpath As String 'excelファイルのパス用変数
'ファイルを開くダイアログを開く。
'ダイアログに「Excelブック,*xlsx」とexcelファイルが見えるように設定される。選択したファイル名がbookpathへ代入される
bookpath = Application.GetOpenFilename("Excelブック,*.xlsx")
If bookpath = "False" Then End 'ファイルを開くでキャンセルした場合は、処理を終了
'対象フォルダの取得 ブックのパスからファイル名を削除してパス名として切り出し
' left(文字列,文字数)で対象文字列左端から指定数分取得
' InStrRev(検索対象文字列,検索文字列)で検索文字列が何番目に見つかったかを返す
fldpath = Left(bookpath, InStrRev(bookpath, "\")) '\が見つかったら、そこから左側の文字列だけ切り出すと指定したファイルが配置されているフォルダ名が取れる
End Sub
他のファイルをリンクしている場合の処理について
今回使用したファイルは、vlookup関数が含まれているファイルになっています。
そのため、ファイルを開いたタイミングでリンクの更新を聞かれるのですが、日付を全ファイルに書き換えるだけの処理で、参照先データの変更の必要性がありません。
しかし、VBAで通常の状態でファイルを開くと、必ずと言っていいほどリンクの更新ダイアログが出てくるので、「日付入力処理を自動化したのになぜかダイアログでボタンをクリックする」というわけのわからない作業が発生するので、このダイアログもプログラム中で起動しないように設定します。
プログラムを使わないでリンクの更新をオフにする方法もある
Excelのデータタブからリンクの編集を開くと、リンク元がわかるようになっています。
このダイアログの「起動時の確認」をクリックします。
選択肢として、自動リンク更新にするかの設定ができるので、必要に応じてオフにすることでダイアログを出さないようになります。
今回は、通常時には毎回確認を取る設定をしていて、この箇所を変更すると不都合だったので、必ずダイアログが出るようになっています。
そのため、Openメソッドの引数を設定しダイアログを出さずに処理を進めるという設定にしました。
Workbooks.Open Filename:=file_name, UpdateLinks:=0
UpdateLinksですが、以下のような設定になります。（〇：更新 ×：非更新）
0 外部参照 × リモート参照 ×
1 外部参照 〇 リモート参照 ×
2 外部参照 × リモート参照 〇
3 外部参照 〇 リモート参照 〇
引数UpdateLinksを使うことで、プログラム実行時にリンク更新のダイアログをオフにすることができるようになりました。
これで、同一フォルダ内に複数のファイルがあり、すべてのファイルの１つのシートに日付を入力する処理を自動化できます。
同じ条件であれば、振り分け処理も必要ないのですが、もしもやりたいことが同じでも、条件が少し違ってしまう場合の参考にしてください。
コメント