エクセルVBAでBOOKを開く際の処理

質問

エクセルVBAでBOOKを開く際の処理
エクセル2000です。
VBAで特定のフォルダー内のBOOKを開き、１枚目のシートSheets(1)のデータを読み込んで別BOOK（マクロを記載したBOOK）にコピペしたら保存せず閉じるコードを下記のように書きました。（かなり簡略化しましたが）
これで作動するのですが、万一、そのフォルダー内のBOOKが開いていても１枚目のシートのデータを読み込み後、閉じられてしまいます。
BOOKが開いていれば、その開いていたBOOKは閉じず、先に進むようにするにはどのように直せばいいでしょうか？

Sub TEST01()

　　Dim mb As Workbook, wb As Workbook
　　Dim myfd As String, fnme As String, ans As Byte, i As Long

　　ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね？", vbYesNo + vbQuestion, "（￣∇￣) ？ ")
　　If ans = vbNo Then
　　　　MsgBox "それじゃだめです。", vbCritical, "Σ（￣ロ￣lll)"
　　　　Exit Sub
　　End If

　　Set mb = ThisWorkbook
　　myfd = mb.Path
　　fnme = Dir(myfd & "\*.xls")

　　Do Until fnme = Empty
　　　　If fnme <> mb.Name Then
　　　　　　Set wb = Workbooks.Open(myfd & "\" & fnme)
　　　　　　i = i + 1
　　　　　　mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")
　　　　　　wb.Close (False) '保存せずに閉じる
　　　　End If
　　　　fnme = Dir
　　Loop

　　Set mb = Nothing
　　Set wb = Nothing
　　MsgBox i
End Sub

回答No.4

Wendy02 · ベストアンサー

ほんのちょっとの所を直しました。基本的には、単に付け足すだけです。変えた部分は、私の知っている書法の一部分です。

'//
Sub Test01r()
　Dim mb As Workbook, wb As Workbook
　Dim myFd As String, Fnme As String, ans As Integer, i As Long
　Dim flg As Boolean
　ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね？", vbYesNo + vbQuestion, "（￣∇￣) ？ ")
　If ans = vbNo Then
　　MsgBox "それじゃだめです。", vbCritical, "Σ（￣ロ￣lll)"
　　Exit Sub
　End If

　Set mb = ThisWorkbook
　myFd = mb.Path
　Fnme = Dir(myFd & "\*.xls")

　Do Until Fnme = ""
　　If Fnme <> mb.Name Then
　　　On Error Resume Next
　　　Set wb = Workbooks(Fnme)
　　　If wb Is Nothing Then
　　　　Set wb = Workbooks.Open(myFd & "\" & Fnme)
　　　　flg = True
　　　End If
　　　On Error GoTo 0
　　　i = i + 1
　　　mb.Worksheets(1).Cells(i, 1).Value = wb.Worksheets(1).Range("S10").Value
　　　If flg Then
　　　　wb.Close False '保存せずに閉じる
　　　　flg = False
　　　End If
　　End If
　　Set wb = Nothing
　　Fnme = Dir()
　Loop

　Set mb = Nothing
　MsgBox i & "個を取得しました", vbInformation
End Sub

お礼

ありがとうございます。
最小限の手直しでできる方法ですね、たすかりました。
ばっちりです！

回答No.5

keithin

ん？　ごめんなさいね。つまんないとこで誤記って，ご迷惑をおかけましました。

間違い：
mb.Sheets(1).Cells(i, 1) = Workbooks(fname).Sheets(1).Range("S10")

正解：
mb.Sheets(1).Cells(i, 1) = Workbooks(fnme).Sheets(1).Range("S10")

お礼

ありがとうございます。
気が付きませんでした。
やはり
Option Explicit
必要ですねえ・・・・。

回答No.3

mimeu

そんなに難しくしないでも、関数をひとつ作れば話が簡単になります。
たとえば、こんな感じです。

本文の中で
　　Dim b既に開いている As Boolean
　　Do Until fnme = Empty
　　　　If fnme <> mb.Name Then
　　　　　　If 既に開いている(fnme) Then
　　　　　　　　b既に開いている = true
　　　　　　　　Set wb = Workbooks(fnme)
　　　　　　Else
　　　　　　　　b既に開いている = false
　　　　　　　　Set wb = Workbooks.Open(myfd & "\" & fnme)
　　　　　　End If
　　　　　　i = i + 1
　　 ～～～～　中略　～～～～
　　　　　　If Not b既に開いている Then （ファイルを閉じるロジック）
　　 ～～～～　以下省略　～～～～

Function 既に開いている(ファイル名 As String) As Boolean
　　Dim ブック As Workbook
　　For Each ブック In Application.Workbooks
　　　　If ファイル名 = ブック.Name Then
　　　　　　既に開いている = True
　　　　　　Exit Function
　　　　End If
　　Next
　　既に開いている = False
End Function

お礼

なるほど、いろいろやりかたがありますね。
勉強になります。
ありがとうございました。

回答No.2

mt2008

On Error Resume Nextを使った手抜きの方法を。

開くブック名が決まったら、On Error Resume Nextを設定して、そのブック名をWorkbooks.Nameで取得して変数に代入します。
既に開いてあるブックならブック名が取得できますし、開いていなければエラーで次に処理が進むため変数は空っぽになります。
で、閉じる時にその変数が空っぽ＝開いていなかった　場合、保存せずに閉じます。

以下、Do Until fnme = Empty　のループ部分のみ

　　Do Until fnme = Empty
　　　　If fnme <> mb.Name Then
　　　　　　chk = ""
　　　　　　On Error Resume Next
　　　　　　　　chk = Workbooks(fnme).Name
　　　　　　On Error GoTo 0

　　　　　　Set wb = Workbooks.Open(myfd & "\" & fnme)

　　　　　　i = i + 1
　　　　　　mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")
　　　　　　If chk = "" Then wb.Close (False) '保存せずに閉じる
　　　　End If
　　　　fnme = Dir
　　Loop

お礼

なるほど！
目からうろこの方法です。
ありがとうございました。

回答No.1

keithin

たとえばジミチーに，当該のブックが既に開いてるかどうかチェックしながら進めるようにするのも簡単な手の一つですね。

　dim book_is_Open_flg as boolean
'　　：(中略)
　Do Until fnme = Empty
　　If fnme <> mb.Name Then

　　　i = i + 1
　　　on error goto errhandle
　　　mb.Sheets(1).Cells(i, 1) = workbooks(fname).Sheets(1).Range("S10")
　　　on error goto 0

　　　if book_is_Open_flg = true then
　　　　workbooks(fname).close false
　　　　book_is_Open_flg = false
　　　end if

　　End If
　　fnme = Dir
　Loop
　Set mb = Nothing
　Set wb = Nothing
　MsgBox i

　exit sub
errhandle:
　Workbooks.Open(myfd & "\" & fnme)
　book_is_Open_flg = true
　resume
End Sub

もう一個別にエクセルアプリケーションを配下に起動させて，そちらで当該のブックが開いていようがいまいがreadonlyで新たにブックを開いてしまい，値を取ってくるような手もありかもしれません。

お礼

ありがとうございます。
下記のようにやってみましたが最初のBOOKを開いたところで無限ループになってしまいます。

Sub TEST02()

　　Dim mb As Workbook, wb As Workbook
　　Dim myfd As String, fnme As String, ans As Byte, i As Long
　　Dim book_is_Open_flg As Boolean

　　ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね？", vbYesNo + vbQuestion, "（￣∇￣) ？ ")
　　If ans = vbNo Then
　　　　MsgBox "それじゃだめです。", vbCritical, "Σ（￣ロ￣lll)"
　　　　Exit Sub
　　End If

　　Set mb = ThisWorkbook
　　myfd = mb.Path
　　fnme = Dir(myfd & "\*.xls")

　　Do Until fnme = Empty
　　　　If fnme <> mb.Name Then
　　　　　　i = i + 1
　　　　　　On Error GoTo errhandle
　　　　　　mb.Sheets(1).Cells(i, 1) = Workbooks(fname).Sheets(1).Range("S10")
　　　　　　On Error GoTo 0
　　　　　　If book_is_Open_flg = True Then
　　　　　　　　Workbooks(fname).Close False
　　　　　　　　book_is_Open_flg = False
　　　　　　End If
　　　　End If
　　　　fnme = Dir
　　Loop

　　Set mb = Nothing
　　Set wb = Nothing
　　MsgBox i
　　Exit Sub

errhandle:
　　Workbooks.Open (myfd & "\" & fnme)
　　book_is_Open_flg = True
　　Resume
End Sub