エクセル2003仕様のマクロを2007以降でも使えるようにしたい

任意のフォルダの中に、特定の名前がついたシートがあるファイルが複数あります。
特定の名前のシートのみコピーして、一つのファイルに集約したいです。

ダメもとで公開されている2003仕様の下記のコードを試してみたのですが、うまくいきません。
これを2007以降でも動くようにするには、どう直せばいいでしょうか。
（もし大改築しなければならないのでしたら、別の方法を考えます。なお拡張子の部分のみ、手を加えてあります）

どうぞよろしくお願い致します。

Sub すべてのブックから指定シートを取り込む()
'オブジェクトを設定する
Set ファイルシステム = CreateObject("Scripting.FileSystemObject")
'指定するシート名を取り込む
対象シート = Cells(1, 1).Text
'読み込むファイルを1個指定する
あるブック = Application.GetOpenFilename("Excelファイル(*.xlsm),*.xlsm")
'親フォルダーを取得する
Set 親フォルダー = ファイルシステム.GetFile(あるブック).ParentFolder
'親フォルダー内の全ファイルに以下の操作をする
For Each ファイル In 親フォルダー.Files
'ファイルを開く
Workbooks.Open ファイル.Path
'ブック名を記憶する
ブック名 = ActiveWorkbook.Name
'開いたファイルの対象シートを右端シートの後ろにコピーする
ActiveWorkbook.Worksheets(対象シート).Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
'開いたファイルを閉じる
Workbooks(ブック名).Close SaveChanges:=False
'シート名を変更する
ThisWorkbook.Worksheets(対象シート).Name = 対象シート + ファイル.Name
Next
End Sub

No.3 回答者： WindFaller 回答日時： 2017/11/02 16:24

#2の回答者です。

>頂きましたコード、ちょっと間があいてしまうのですが、試してみたく思います。
いえ、試す必要性はないのですが、もう一度書き直すべきかは思案中です。

「このマクロそのものが変です。」という意見は変わらないです。
成立するのは、特殊な環境だけです。
動く・動かないというに関わらず、コードは書き換えなくてはいけないです。

>For Each ファイル In 親フォルダー.Files
>'ファイルを開く　
If ファイル.Type Like "XLSM*" Then　'例えば、このようなフィルターを置く
>Workbooks.Open ファイル.Path　
・
・
End If
Next

そのままですとExcelのOpenメソッドに、あらゆるゴミファイルが入り込んでしまいます。

No.2 回答者： WindFaller 回答日時： 2017/11/02 11:22

こんにちは。

現在のVBAというのは、VB6.0 系ですから、Office 97 ぐらいから、基本的には変わっていないと思います。特に、2003は、画期的だったのは、.FrameWork を利用できるのと、VB6のRuntimeを搭載しているということです。現在は、VB7 になっていますが、さほど影響はないと思われます。

ところで、このマクロそのものが変ですね。

>もし大改築しなければならないのでしたら、別の方法を考えます
ということでしたので、なるべく、全体的な雰囲気を壊さないでつなげてみました。
(ほとんどを英語に変えてはいますが……）
>あるブック = Application.GetOpenFilename("Excelファイル(*.xlsm),*.xlsm")
>'親フォルダーを取得する
>Set 親フォルダー = ファイルシステム.GetFile(あるブック).ParentFolder
>'親フォルダー内の全ファイルに以下の操作をする

>なお拡張子の部分のみ、手を加えてあります
元の作者は、あえて、ファイルシステムオブジェクトを使おうとしていたように思います。

これは、ファイルシステムオブジェクトを活かそうとるすと、逆に、ややこしいです。
以下は、見本とは言えません。返って、ややこしくしているし、マクロを使うのにためらいを感じます。
以下は、「親フォルダーを取得する」が、二重になっていてお世辞にも褒められないコードになってしまいました。バカなコードを書いたという自覚はあります。（^^;


'//標準モジュールがよい
Sub getSheetsinSelectedBooks()
　Dim objFSO As Object
　Dim 対象シート As String　'ソースのシート名
　Dim BaseFolder As String
　Dim objFolder As Object
　Set objFSO = CreateObject("Scripting.FileSystemObject")
　'指定するシート名を取り込む
　対象シート = ActiveSheet.Cells(1, 1).Value
　'親フォルダーを取得する
　With Application.FileDialog(msoFileDialogFolderPicker)
　　.AllowMultiSelect = False
　　.Show
　　If .SelectedItems.Count > 0 Then
　　　BaseFolder = .SelectedItems(1)
　　End If
　End With
　'親フォルダー内の全ファイルに以下の操作をする
　Set objFolder = objFSO.Getfolder(BaseFolder)
　For Each fn In objFolder.Files
　　'ファイルを開く
　　If Dir(fn.Name, vbNormal) Like "*.xlsm" Then　'拡張子
　　　With Workbooks.Open(fn.Path)
　　　　'開いたファイルの対象シートを右端シートの後ろにコピーする
　　　　.Worksheets(対象シート).Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
　　　　'シート名を変更する
　　　　ThisWorkbook.ActiveSheet.Name = 対象シート & fn.Name
　　　　'開いたファイルを閉じる
　　　　.Close False
　　　End With
　　End If
　Next
End Sub

この回答へのお礼

ご回答ありがとうございます。
あまりにもカッコワルイ結末なのですが、皆様から補足要求を受けた上で再度テストをしてみましたら、何の問題もなく動きました。

以前テストした際は確か

「シートの取り込み」ボタン押下
　　↓
「ファイルを開く」ウィンドウが立ち上がる
　　↓
ファイルを選んで「開く」ボタン押下
　　↓
何も起こらずに終了

だったような気がするのですが…大変失礼致しました。

頂きましたコード、ちょっと間があいてしまうのですが、試してみたく思います。
そのため、この質問はしばらくは締め切らずにおこうと思います。

お礼日時：2017/11/02 15:13

No.1 回答者： GooUserラック 回答日時： 2017/11/02 10:14

逆は良くありますが…

ちなみにどこかでエラーが出るのでしょうか？出るならばそれを提示してください。
出ないのならば何が出来ないかを提示してください。
ちなみに「あるブック = Application.GetOpenFilename("Excelファイル(*.xlsm),*.xlsm")」は、どう見ても Excel2007 以降の物ですけど…
ここだけ直したと言う事ですか？これだとマクロ有効のファイルのみの選択になり、通常の拡張子が「xlsx」の物は対象外になりますけど…

この回答へのお礼

ご回答ありがとうございます。
あまりにもカッコワルイ結末なのですが、皆様から補足要求を受けた上で再度テストをしてみましたら、何の問題もなく動きました。

以前テストした際は確か

「シートの取り込み」ボタン押下
　　↓
「ファイルを開く」ウィンドウが立ち上がる
　　↓
ファイルを選んで「開く」ボタン押下
　　↓
何も起こらずに終了

だったような気がするのですが…大変失礼致しました。

お礼日時：2017/11/02 15:11