複数のエクセルデータ上特定位置の値を一つのセルに２

質問

前回の質問「複数のエクセルデータ上特定位置の値を一つのセルに」に対し、ベストアンサーを教えていただきました。その質問とご回答のポイントは次の通りです。

質問：
大量の同じフォーマットのエクセルファイル（Book1,Book2...）があり、それぞれのBookファイルの「NO.」シートのD6セルには番号が入っています。それぞれファイルでSheet1の特定のセル（例えばB4セル）の値を「データ」ファイルのSeet1にまとめたいです。「データ」ファイルのA列には「NO.」が入力されているので、Bookファイルの値はそれぞれ対応する番号の右側3番目のセルに移したいです。

ご回答：
sub macro1()
　dim myPath as string
　dim myFile as string
　dim myNo as variant
　dim myRng as range

　on error resume next
　application.screenupdating = false
　mypath = "c:\test\"　’book1,2,3…の保存場所を指定する事
　myfile = dir(mypath & "*.xlsx")　’拡張子を正しく指定すること

　do until myfile = ""
　　workbooks.open mypath & myfile
　　myno = workbooks(myfile).worksheets("No.").range("D6").value
　　set myrng = thisworkbook.worksheets("Sheet1").range("A:A").find(what:=myno, lookin:=xlvalues, lookat:=xlwhole)
　　myrng.offset(0, 3).value = workbooks(myfile).worksheets("Sheet1").range("B4").value
　　workbooks(myfile).close savechanges:=false
　　myfile = dir()
　loop
　application.screenupdating = true
end sub

現在Excel2007を使っており、Bookファイルが全部(.xlsx)の状態では問題なく使えましたが、ファイルが97-2003の(.xls)バージョンになると、マクロを実行したときに次のメッセージが出ます。「データ.xlsmは既に開いています。2重に開くと、これまでの変更内容は破棄されます。データ.xlsmを開きますか?」
もちろんご回答の中の「myfile = dir(mypath & "*.xlsx")　’拡張子を正しく指定すること」は（"*.xls"）に変更されている状態です。

何が問題なのか全く分からず、困っています。どなたか教えていただけないでしょうか?
よろしくお願い致します。

回答No.2

keithin · ベストアンサー

はい，ではとりあえず暫定的に

Do Until myFile = ""

　if myfile <> thisworkbook.name then　’追加
　　Workbooks.Open myPath & myFile
　　myNo = Workbooks(myFile).Worksheets("NO.").Range("D6").Value
　　Set myRng = ThisWorkbook.Worksheets("Sheet1").Range("A:A").Find(what:=myNo, LookIn:=xlValues, lookat:=xlWhole)
　　myRng.Offset(0, 3).Value = Workbooks(myFile).Worksheets("申込１").Range("D4").Value
　　Workbooks(myFile).Close savechanges:=False
　end if　’追加

　myFile = Dir()
Loop

としてみましょう。

お礼

できました！！！
本当に助かりました。
何度もご丁寧にありがとうございました。

回答No.1

keithin

寄せられた回答のマクロを適切に手直しできてないのが原因です。
こういうご相談では、教わった回答をコピーして再掲示してもダメです。あなたが「具体的にどこにどう手を入れてミスったのか」、何の説明もされてないからです。

そういうときは、「いま実際にアナタがあなたのエクセルで動かしてるそのマクロ」を、手抜きせずにあなたのエクセルからコピーして全部情報提供してください。
そうすればマクロのどこをミスったのか、それとも前回や今回のご質問で説明できてない/説明し忘れてる何かが問題の原因になってるのか、少しはヒントになるはずです。

補足

ご指摘ありがとうございました。
本人の知識が足りなく、大変失礼しました。それでは具体的に抱えている問題を説明させていただきます。
実際の業務で使われているファイルはほとんどエクセル97-2003バージョン(.xls)です。業務で使っているファイルは直接お見せすることができないので、実際の状況になるべく近づけるようにサンプルを工夫しました。

サンプルファイルが入っているフォルダの場所：E:\test
サンプルファイル：Book1.xls, Book3.xls, データ.xlsm

Book1.xlsとBook3.xlsにはそれぞれ「申込１」と「NO.」ワークシートがあり、「申込１」SheetのD4セルにそれぞれの値、「NO.」SheetのD6セルにはそれぞれの番号が入っています。

教えていただいたマクロを次のように直しました。

Sub macro1()
Dim myPath As String
Dim myFile As String
Dim myNo As Variant
Dim myRng As Range

On Error Resume Next
Application.ScreenUpdating = False
myPath = "E:\test\" 'book1,2,3…の保存場所を指定する事
myFile = Dir(myPath & "*.xls") '拡張子を正しく指定すること

Do Until myFile = ""
Workbooks.Open myPath & myFile
myNo = Workbooks(myFile).Worksheets("NO.").Range("D6").Value
Set myRng = ThisWorkbook.Worksheets("Sheet1").Range("A:A").Find(what:=myNo, LookIn:=xlValues, lookat:=xlWhole)
myRng.Offset(0, 3).Value = Workbooks(myFile).Worksheets("申込１").Range("D4").Value
Workbooks(myFile).Close savechanges:=False
myFile = Dir()
Loop
Application.ScreenUpdating = True
End Sub

このマクロを実行した結果、例のメッセージボックスが現れ、「はい」を押すと何も変化が現れなく、「いいえ」を押すとファイルが閉じられます。
ただし、ファイルの拡張子とマクロを.xlsxに直すと問題なく実行してくれます。

それでは以上の質問に対し、ご指導よろしくお願い致します。