VBA 探しているFileがないときの処理方法

質問

現在、下記のようにしてマクロ実行ブックと同じ階層のフォルダ名を取得してAに、フォルダ内のabc.XLSのC9の値をBに、abc.XLSの更新日時をCに表示させています。
このとき、フォルダ内にabc.XLSが無い場合にファイル名をAに書き出してB及びCは空白というように表示したいのですが、どのようにすればよろしいでしょうか。
macro1は以前質問させて頂いたものがベースになっています。ExecuteExcel4Macroを使っている関係でファイル名が無いときの処理はDirを使ってできるとmougで調べてわかりましたが、自分の知識ではできず、macro2を作成したのですが、指定ファイルがない場合の処理がうまくできずにいます。
macro1はファイルオープンの窓が開きます。macro2はファイルが存在しないという窓が開きます。
どちらの場合でもかまいませんのでお力をお貸し頂けませんでしょうか。

Sub macro1()
Dim myPath As String
Dim myFolder As String
Dim r As Long
r = 3
myPath = ThisWorkbook.Path & "\"
myFolder = Dir(myPath, vbDirectory)
myBook = "abc.XLS"
Application.ScreenUpdating = False
Range("A3:C60").Clear
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder
Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3")
On Error Resume Next
Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook)
On Error GoTo 0
If Cells(r, 3) = "" Then
Cells(r, 2) = "myBook"
End If
Cells(r, 2).NumberFormatLocal = "#,##0_ "
Cells(r, 3).NumberFormatLocal = "y""年""m""月"""
With Range("A3:C60")
.Sort Key1:=Range("C3"), Order1:=xlAscending
.Borders.LineStyle = True
End With
r = r + 1
End If
End If
myFolder = Dir()
Loop
Application.ScreenUpdating = True
End Sub

Sub Macro2()
Dim myPath As String
Dim myFolder As String
Dim myBook As String
myPath = ThisWorkbook.Path & "\"
myFolder = Dir(myPath, vbDirectory)
myBook = "abc.XLS"
i = 2
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Workbooks.Open (myPath & myFolder & "\" & myBook)
Range("C9").Activate
Selection.Copy
ThisWorkbook.Activate
Cells(i, 1) = myFolder
Cells(i, 2).PasteSpecial xlValues
Cells(i, 3) = FileDateTime(myPath & myFolder & "\" & myBook)
Workbooks(myBook).Close SaveChanges:=False
i = i + 1
End If
End If
myFolder = Dir()
Loop
End Sub

回答No.3

ki-aaa · ベストアンサー

#1です。macro1を動くようにしました。

次のところに余分な空白がありました
myBook & "]Sheet1■'!R9C3")

それから、
f myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
について理解できないので参考になるホームページなどがありましたら紹介してください。

Sub macro1()
Dim myPath As String
Dim myFolder As String
Dim myBook As String
Dim r As Long
r = 3
myPath = ThisWorkbook.Path & "\"
myFolder = Dir(myPath, vbDirectory)
myBook = "abc.XLS"
Application.ScreenUpdating = False
Range("A3:C60").Clear
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder
On Error Resume Next
Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook)
If Err.Number = 0 Then
'Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3")
Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1'!R9C3")
Cells(r, 2).NumberFormatLocal = "#,##0_ "
Cells(r, 3).NumberFormatLocal = "y""年""m""月"""
Else
Cells(r, 2) = ""
Cells(r, 3) = ""
End If
r = r + 1
End If
End If
myFolder = Dir()
Loop
With Range("A3:C60")
.Sort Key1:=Range("C3"), Order1:=xlAscending
.Borders.LineStyle = True
End With
Application.ScreenUpdating = True
End Sub

お礼

ご回答ありがとうございました。
余分なスペースは「○○○　」となっているシートの名前の○を消してSheet1にしたために発生したスペースでした。
お世話をお掛けしました。

補足

ご連絡が遅くなりました。

>If myFolder <> "." And myFolder <> ".." Then　
>If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
>について理解できないので参考になるホームページなどがありましたら
>紹介してください。

の部分についてのご連絡が遅くなり申し訳ございません。
http://www.asahi-net.or.jp/~zn3y-ngi/YNxv251.html
こちらのサイトの手法を参考に作成させて頂いたため、当方も完全には理解できておりませんが、コメントアウトがあります。
If myFolder <> "." And myFolder <> ".." Then
　'現在フォルダと親フォルダでなければ
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
　'取得した名前がフォルダなら
ということのようです。

URLの
4) フォルダ名を取得してワークシートに表示する
の部分を読んで頂ければki-aaa様ならご理解頂けるのではないでしょうか。

回答No.8

goota33

大文字と小文字も区別するのでそれが原因ですね。
myBook変数に代入している「abc.XLS」を
「abc.xls」に変えてください。
それで私の環境では判定できました。

Dim myPath As String
Dim myFolder As String
Dim r As Long
Dim blnFlag As Boolean
r = 3

myPath = ThisWorkbook.Path & "\"
myFolder = Dir(myPath, vbDirectory)

'拡張子を大文字のXLSからxlsに変える
myBook = "abc.xls"
blnFlag = False
Application.ScreenUpdating = False
Range("A3:C60").Clear

あと
MsgBox myFolder '同一階層に存在するファイル、フォルダが表示されます

でメッセージボックスの表示が必要ないのであれば
削除してしまってください。
マクロの動作確認時に私が勝手につけただけのものなので。

お礼

度重なる補足に対し、ご丁寧にお返事頂きましたことを心より感謝致しております。
本当にお世話になりました。
無事エラーがでずに動作することができました。
ありがとうございました。

補足

ご呈示頂いた変更だけでは当方環境では上手く動作せず、色々と考えて下記の場所を変更したところ無事動きました。
コメントアウトで変更箇所を備忘録にもなるように書いておきます。

2回目のDOの付近ですが、
If blnFlag = True Then
　'blnFlag=Trueだけに書き換え
myFolder = Dir(myPath, vbDirectory)
r = 3
Do Until myFolder = ""
If myFolder <> "." And myFoler <> ".." Then
　'FolerになっているのでFolderに変更

この処理で無事動作確認ができました。

goota33様の環境でIfでも動作するのに、こちらで動作しない原因はわかりませんが、現在動作しておりますので、この形で使えるのではないかと思っております。
MsgBoxは削除させて頂きました。

回答No.7

goota33

blnFlag変数にTrueを入れる条件分岐の場所が間違ってました、、、
一つ目のループを以下のコードに書き換えてください。
前のコードだとmyFolder変数に入ってる値がディレクトリの名前だと判断したときだけしか
現在のフォルダの中に「abc.xls」があるかないかのチェックを行いません。

Do Until myFolder = ""
MsgBox myFolder
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder

r = r + 1
End If

'今回の変更箇所
'blnFlag変数にTrueを入れる条件分岐をここに移す。
If myFolder = myBook Then blnFlag = True
End If
myFolder = Dir()
Loop

Dir関数に関しては参照ＵＲＬの説明をそのまま引用させていただきます。

Dir関数は、引数に指定したファイルが存在すると、そのファイル名を返し、存在しないと空欄("")を返します。
Dir関数が返すのは、パスを含まないファイル名です。たとえば「Dir("C:\Sample\Book2.xlsx")」は「Book2.xlsx」を返します。

なので同じフォルダ内に「abc.xls」があればmyFolder変数にも「abc.xls」が入ります。

参考URL：

http://officetanaka.net/excel/vba/file/file06.htm

お礼

親身になって回答して頂きまして誠にありがとうございます。
心よりお礼申しあげます。

補足

現状の記載マクロとF8で順番に処理を行ったときの動作をコメントアウトで記載させて頂きます。
Sub macro1()
Dim myPath As String
Dim myFolder As String
Dim r As Long
Dim blnFlag As Boolean
r = 3
myPath = ThisWorkbook.Path & "\"
myFolder = Dir(myPath, vbDirectory)
myBook = "abc.XLS"
blnFlag = False
Application.ScreenUpdating = False
Range("A3:C60").Clear
Do Until myFolder = ""
MsgBox myFolder'同一階層に存在するファイル、フォルダが表示されます
'　.　及び　..　を含みます
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder
'A3から順番に全てのフォルダ名が記載れていきます
'abc.XLSがないフォルダ名も記載されます
'abc.XLSがないフォルダにはefg.xlsが存在しますが、この処理には必要ないものです
r = r + 1
End If
If myFolder = myBook Then blnFlag = True
'ここのblnFlarは常にFalseになっています。
End If
myFolder = Dir()
Loop
If blnFlag = True Then
'ここのblnFlarがFalseになっていてIfの間の処理が飛びます
myFolder = Dir(myPath, vbDirectory)
r = 3
Do Until myFolder = ""
If myFolder <> "." And myFoler <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3")
On Error Resume Next
Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook)
On Error GoTo 0
If Cells(r, 3) = "" Then
Cells(r, 2) = "myBook"
End If
Cells(r, 2).NumberFormatLocal = "#,##0_ "
Cells(r, 3).NumberFormatLocal = "y""年""m""月"""
With Range("A3:C60")
.Sort Key1:=Range("C3"), Order1:=xlAscending
.Borders.LineStyle = True
End With
r = r + 1
End If
End If
myFolder = Dir()
Loop
Else
'Ifの処理が飛んでいるのでここにきます
myFolder = Dir(myPath, vbDirectory)
r = 4
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
Cells(r, 1) = myFolder
'A4から順番に、全てのファイル、フォルダ名が記入されます。
'.　..　は含みません。
r = r + 1
End If
myFolder = Dir()
Loop
End If
Application.ScreenUpdating = True
End Sub

コメントで書きましたように、IfからElseに作業が移り、B列　C列に書き出す処理が丸々飛ばされてしまっております。
こちらの修正の仕方が悪い可能性もございますので全て記載させて頂きました。
全てお任せ状態であり、非常に申し訳なく思っております。
お力添えに感謝を致しております。

回答No.6

goota33

ああ、そういうことですか。
なら
'変更箇所
'条件分岐が一つ増えたのでここで閉じる
End If
Application.ScreenUpdating = True

の上に以下のコードを追加してください。
Ａ列に現在のディレクトリの中にあるファイル名が書き出されます。
Else
myFolder = Dir(myPath, vbDirectory)
r = 4
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
Cells(r, 1) = myFolder

r = r + 1
End If
myFolder = Dir()
Loop

形としてはこんな感じです。
'変更箇所
'blnFlagがTrueならabc.XLSが存在したということなので、
'ここからB列とC列に値を入れる。
If blnFlag = True Then
myFolder = Dir(myPath, vbDirectory)
r = 3
Do Until myFolder = ""
If myFolder <> "." And myFoler <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then

Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3")

On Error Resume Next
Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook)

On Error GoTo 0
If Cells(r, 3) = "" Then
Cells(r, 2) = "myBook"

End If

Cells(r, 2).NumberFormatLocal = "#,##0_ "
Cells(r, 3).NumberFormatLocal = "y""年""m""月"""
With Range("A3:C60")
.Sort Key1:=Range("C3"), Order1:=xlAscending
.Borders.LineStyle = True

End With
r = r + 1

End If
End If

myFolder = Dir()
Loop

Else
myFolder = Dir(myPath, vbDirectory)
r = 4
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
Cells(r, 1) = myFolder

r = r + 1
End If
myFolder = Dir()
Loop
'変更箇所
'条件分岐が一つ増えたのでここで閉じる
End If

お礼

ご回答ありがとうございました。

補足

お昼休みに早速実行させて頂きました。
結果、A４以下にマクロを記述したエクセルのファイル名を含む全てのファイル、フォルダが記載され、B,Cには何も記入されませんでした。
If blnFlag = True Thenの部分で
Elseの処理に向かい、A4から+1しながら全てのファイル名を書き出す。
という形になっております。

値が格納されているはずのIf blnFlag = True Thenの処理が進行しないという状況です。
>'変更箇所
>'myFolderとmyBookを比較して、同じ名前ならblnFlagにTrueを代入する
この分ですが、同じ名前にはならない気がするのですが。1フォルダのacc.XLS　2フォルダのabc.XLSとなりますので、
If myFolder = myBook Then blnFlag = True
は一致しないような気がするのですが、問題ないのでしょうか。
初心者な為的外れなことを書いておりましたら申し訳ございません。

時間の都合で今回は別の回答者の方のお答えを使わさせて頂きますが、こちらの方法も使えるようにしたいという思いから当方で実行した環境を逐一ご報告させて頂いております。
ご迷惑をお掛けしまして申し訳ございません。

回答No.5

goota33

すいません。
一文抜けてました（汗）

'変更箇所
'ディレクトリにabc.XLSが存在するかしないかを確認するため、
'いったんループを区切ってディレクトリに存在するファイル名を一通りチェックする。
Do Until myFolder = ""
MsgBox myFolder
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder

'変更箇所
'myFolderとmyBookを比較して、同じ名前ならblnFlagにTrueを代入する
If myFolder = myBook Then blnFlag = True
r = r + 1
End If
End If
Loop

このループの中に
myFolder =Dir()を入れてください。
以下のような感じです。

'変更箇所
'ディレクトリにabc.XLSが存在するかしないかを確認するため、
'いったんループを区切ってディレクトリに存在するファイル名を一通りチェックする。
Do Until myFolder = ""
MsgBox myFolder
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder

'変更箇所
'myFolderとmyBookを比較して、同じ名前ならblnFlagにTrueを代入する
If myFolder = myBook Then blnFlag = True
r = r + 1
End If
End If

'一文を追加するところ
myFolder = Dir()
Loop

この一文を追加することで
最初の
myFolder = Dir(myPath, vbDirectory)

の部分で取得したDir関数の配列の値を、myFolder変数の中に代入できます。
Dir関数についての詳しい説明は以下の参照ＵＲＬをごらんになってください。
動作確認もろくにせず、いい加減なコードを書いてすいませんでした。

参考URL：

http://officetanaka.net/excel/vba/tips/tips95.htm

お礼

ご回答ありがとうございました。

補足

myFolder = Dir()
の無い件は補足入力後に気がつきまして、実行させて頂きました。
しかし、その後の

If blnFlag = True Then
myFolder = Dir(myPath, vbDirectory)
r = 3
Do Until myFolder = ""
If myFolder <> "." And myFoler <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbCirectory Then

こちらの

If blnFlag = True Then

の部分で最終行のEnd　IFまで飛んでしまい

Application.ScreenUpdating = True
End Sub

と進んでファイル名が書き出されただけで処理が終了してしまいます。
今夜にでもじっくり悩んでみます。

回答No.4

ki-aaa

#3です。
On Error GoTo 0　が抜けていました。
次のようにしてください。

Cells(r, 3) = ""
End If
On Error GoTo 0
r = r + 1

すみませんでした。

お礼

ご回答ありがとうございました。
無事実行することができました。
両方のやり方についてお答え頂きましてありがとうございます。
双方とも今後のスキルアップの為に活用させて頂きます。

補足

>If myFolder <> "." And myFolder <> ".." Then　
>If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
>について理解できないので参考になるホームページなどがありましたら
>紹介してください。

こちらの部分ですが、詳しく書かれているサイトを見付けましたのでご紹介させて頂きます。
http://officetanaka.net/excel/vba/tips/tips95.htm
以下抜粋
「.」と「..」とは何でしょう。MS-DOSの時代には必須の知識だったのですが、「.」は自分自身のフォルダを表し「..」は1つ上のフォルダを意味しています。

以上
上記は
If myFolder <> "." And myFolder <> ".." Thenの部分だけですが、
サイトを見て頂きますと
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
に対応する部分も記述がありますのでご参考になれば幸いです。

回答No.2

goota33

macro1()関数を変更してお答えします。
変更したところはコメントアウトとして明記したので
確認してください。
ただし動作確認を行っていないのと、
ディレクトリにあるファイル名を確認するため
ループを二回に増やしたので多少処理する時間は長くなるかもしれません。

Sub macro1()
Dim myPath As String
Dim myFolder As String
Dim r As Long

'変更箇所
'真か偽かの二値を格納する変数
Dim blnFlag As Boolean

r = 3
myPath = ThisWorkbook.Path & "\"
myFolder = Dir(myPath, vbDirectory)
myBook = "abc.XLS"

'変更箇所
'blnFlagの初期値を設定
blnFlag = False

Application.ScreenUpdating = False
Range("A3:C60").Clear
'変更箇所
'ディレクトリにabc.XLSが存在するかしないかを確認するため、
'ループを区切ってディレクトリに存在するファイル名を一通りチェックする。
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder

'変更箇所
'myFolderとmyBookを比較して、同じ名前ならblnFlagにTrueを代入する
If myFolder = myBook then blnFlag = True
r = r + 1
end if
End If
Loop

'変更箇所
'blnFlagがTrueならabc.XLSが存在したということなので、
'ここからB列とC列に値を入れる。
If blnFlag = True then
myFolder = Dir(myPath, vbDirectory)
r = 3
Do Until myFolder = ""
if myFolder <> "." And myFoler <> ".." Then
if GetAttr(MyPath & myFolder) And vbDirectory) = vbCirectory then

Cells(r, 2).Value = ExecuteExcel4Macro("'" & myPath & myFolder & "\[" & myBook & "]Sheet1 '!R9C3")

On Error Resume Next
Cells(r, 3) = FileDateTime(myPath & myFolder & "\" & myBook)

On Error GoTo 0
If Cells(r, 3) = "" Then
Cells(r, 2) = "myBook"

End If

Cells(r, 2).NumberFormatLocal = "#,##0_ "
Cells(r, 3).NumberFormatLocal = "y""年""m""月"""
With Range("A3:C60")
.Sort Key1:=Range("C3"), Order1:=xlAscending
.Borders.LineStyle = True

End With
r = r + 1

End If
End If

myFolder = Dir()
Loop
'変更箇所
'条件分岐が一つ増えたのでここで閉じる
End If
Application.ScreenUpdating = True

End Sub

お礼

ご回答ありがとうございました。

補足

ご呈示頂きましたコードを当方環境に入れてみると
if GetAttr(myPath & myFolder) And vbDirectory) = vbCirectory then
で構文エラーになってしまいました。
If (GetAttr(myPath & myFolder) And vbDirectory) = vbCirectory Then
で解決できたのですが、
'変更箇所
'ディレクトリにabc.XLSが存在するかしないかを確認するため、
'ループを区切ってディレクトリに存在するファイル名を一通りチェックする。
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then
Cells(r, 1) = myFolder

'変更箇所
'myFolderとmyBookを比較して、同じ名前ならblnFlagにTrueを代入する
If myFolder = myBook Then blnFlag = True
r = r + 1
End If
End If
Loop
この間の
If myFolder <> "." And myFolder <> ".." Then
に一致する条件が無いためかF8でしばらく放置してもループをずっとしております。
解決策等ございましたらご教授お願い致します。

回答No.1

ki-aaa

macro2です

Sub Macro2()
Dim i
Dim myPath As String
Dim myFolder As String
Dim myBook As String
Application.ScreenUpdating = False
myPath = ThisWorkbook.Path & "\"
myFolder = Dir(myPath, vbDirectory)
myBook = "abc.XLS"
i = 2
Do Until myFolder = ""
If myFolder <> "." And myFolder <> ".." Then
If (GetAttr(myPath & myFolder) And vbDirectory) = vbDirectory Then

On Error Resume Next
Workbooks.Open (myPath & myFolder & "\" & myBook)
If Err.Number = 0 Then
Range("C9").Copy
ThisWorkbook.Activate
Cells(i, 1) = myFolder
Cells(i, 2).PasteSpecial xlValues
Cells(i, 3) = FileDateTime(myPath & myFolder & "\" & myBook)
Workbooks(myBook).Close SaveChanges:=False
Else
ThisWorkbook.Activate
Cells(i, 1) = myFolder
Cells(i, 2) = ""
Cells(i, 3) = ""
End If
On Error GoTo 0
i = i + 1
End If
End If
myFolder = Dir()
Loop
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。無事思惑のことができました。

補足

ファイル数が増えたり、開くファイルが重いと当然処理速度が遅くなるのですが、解決策等ございますでしょうか？
こういうやりかたは時間がかかるからよりこっちでやったほうがいいという情報でもかまいませんので、ご教授ください。