VBA Excel処理の追加を２点教えてください

質問

Office2003(SP3)

以下は、昔、教えてもらったExcel VBAスクリプトで、よく使わせて
もらってます。「C:\mybooks\」にあるxlsファイル（a001.xls、a002.xls、
a003.xls・・・・）を片っ端から開き、 1つのBookに束ねる動作をします。

これだけでも大変便利なのですが、もう少し改善いたしたく。

(1) 束ねられたBookのSheet名が、Sheet1、Sheet1 (2)、Sheet1 (3)、
Sheet1 (4)・・・　になってしまいます。そこで、ファイル名から拡張子を落
とした文字列をSheet名にセットする記述をご教示下さい。

(2) a001.xls、a002.xls、a003.xls・・・は、それぞれSheet1、Sheet2、
Sheet3を含みます。Sheet1だけが抜き取られてSheet2、Sheet3が残された大量
の残骸Bookが開きっぱなしになります。これら、保存せずに閉じる記述を追加
したいのですが。

よろしくお願い致します。

Sub OpenFiles()
Dim i As Integer
Dim wb As Workbook
Dim fname
Dim dirname As String
'
i = 1
dirname = "C:\mybooks\"
fname = Dir(dirname + "*.htm")
If fname <> "" Then
Do While fname <> ""
If fname <> "." And fname <> ".." Then
If i = 1 Then
' 最初のファイルを開く
Workbooks.OpenText FileName:=dirname + fname
Set wb = ActiveWorkbook
' 最初のファイルを新規ブックに複製して閉じる。
ActiveSheet.Copy
wb.Close
Set wb = ActiveWorkbook
Else
' 2番目以降のファイルは複製した最初のファイルに追加
Workbooks.OpenText FileName:=dirname + fname
ActiveSheet.Move After:=wb.Worksheets(wb.Worksheets.Count)
End If
i = i + 1
End If
fname = Dir
Loop
Else
MsgBox "検索条件を満たすファイルはありません。"
End If
Set wb = Nothing
End Sub

回答No.2

redfox63 · ベストアンサー

こんな感じでいいのでは
Sub GetSheets()
　　Dim sName As String, sDir As String, n As Integer
　　Dim wb As Workbook, w As Workbook
　　Dim ws As Worksheet
　　Dim bflag As Boolean

　　sDir = "c:\mybooks\"
　　sName = Dir(sDir & "a*.htm")
　　' 画面の更新の抑止
　　Application.ScreenUpdating = False
　　While sName <> ""
　　　　' 取得ファイル名のブックを開く
　　　　Application.OpenText FileName:= sDir & sName
　　　　Set w = ActiveWorkbook
　　　　Set ws = w.Sheets("Sheet1")
　　　　' Sheet1の名前を変更
　　　　ws.Name = Replace(sName, ".xls", "")
　　　　If wb Is Nothing Then
　　　　　　' まとめるためのブックを追加
　　　　　　Set wb = Workbooks.Add
　　　　　　bflag = True
　　　　End If
　　　　' 対象シートをコピー
　　　　ws.Copy after:=wb.Worksheets(wb.Worksheets.Count)
　　　　' アラートの抑止
　　　　Application.DisplayAlerts = False
　　　　If bflag Then
　　　　　　' 新規ブックの Sheet1,Sheet2,Sheet3を削除
　　　　　　For n = wb.Worksheets.Count To 1 Step -1
　　　　　　　　If Left$(wb.Worksheets(n).Name, 5) = "Sheet" Then
　　　　　　　　　　wb.Worksheets(n).Delete
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　　　' 開いたブックを閉じる
　　　　w.Close
　　　　' アラートの抑止の解除
　　　　Application.DisplayAlerts = True
　　　　Set ws = Nothing
　　　　Set w = Nothing
　　　　sName = Dir
　　Wend
　　' 画面更新の抑止を解除
　　Application.ScreenUpdating = True

End Sub

# 字下げには全角スペースを使用しています

お礼

redfox63さん、御礼が大変遅くなったことをまずはお詫び申し上げます。

別の作業に追われており、ようやく本件に取り掛かることができました。
さて詳細なコードまでご提示いただき、大変ありがとうございました。

実行してみると、

' 取得ファイル名のブックを開く
Application.OpenText FileName:= sDir & sName

ここで以下のエラーで止まってしまうようです。

「実行時エラー '438':
オブジェクトは、このプロパティまたはメソッドをサポートしていません。」

「Application.OpenText FileName」をGoogleで調べてみましたが、
本質問にしかHITしないようで、、、

当方、Excel2003ですが、「Application.OpenText」はExcel2007など新しい
バージョンでの記述なのでしょうか？

まことに厚かましいですが、もし原因が簡単にわかるようでしたら
ご教示いただけますと幸いです。

回答No.3

redfox63

Application.OpenText は間違えですね
Workbooks.OpenTextです

投稿する際にコメントなどを追加したときに何かを間違えたのだと思います
大変失礼しました m(__)m

お礼

redfox63さん、フォローありがとうございました。
ばっちり動きました、大変作業がはかどります、ありがとうございます。

回答No.1

Sinogi

まずは希望動作のマクロ記録をとりましょう。
シート名の変更に関するコード
ファイルを閉じるコードがすぐにわかるので現コードでループしているうちのどこに入れたらいいか考えましょう。

手作業でする順番を考えればすぐにわかりますよ

お礼

御礼遅くなってすみません。

アドバイスありがとうございました。
記録をとってみたのですが
ファイルを閉じると記録したものも全て吹っ飛んでしまい、
そこで挫折しかけていました、、、

地道に研究してみます。ありがとうございます。