Excel2007VBAシートコピーとマクロ保存

質問

●質問の主旨
複数のシートのファイルにおいて最終シートだけをコピーし、
かつそのファイルの標準モジュールも含んだファイルを保存するには、
下記のコードをどのように書き換えたらいいでしょうか？
ご存知のかたご教示願います。

●コード
Sub 保存()

Dim flname As String

flname = "D:\医療週報\VBA試作\" & Format(Date, "yyyy年mm月") & ".xlsx"
ActiveSheet.Copy

ActiveWorkbook.SaveAs flname
ActiveWorkbook.Close

End Sub

●質問の補足
１）マクロで「保存」を実行するときは手作業で必ず最終ページを開いています（アクティブにします）。
２）上記コードのうち".xlsx"では最終シートだけをコピーできますが、
マクロの保存ができません。また".xlsm"にするとエラーが出ます。
".xls"にすると複数のシートが全てコピーされた上に、マクロの保存ができていません。
３）私はVBA初心者です。

回答No.2

maverik1226 · ベストアンサー

dradra33　様

こんなのでどうでしょう？

特に質問に記載がなかったので「『マクロを実行するブック』の最終ページ(一番右端と解釈しました)を標準モジュール付きで別名保存する」こととして回答します。

それと、結局ファイルの拡張子を何にするのか良く分からなかったのでxlsxにするようにしています。

Sub Tset()
Dim s As Worksheet, flname As String

'保存ファイル名を取得
flname = "D:\医療週報\VBA試作\" & Format(Date, "yyyy年mm月")

'シート削除時のメッセージを非表示
Application.DisplayAlerts = False

'全シートをループ
For Each s In ThisWorkbook.Worksheets

'一番右のシート番号でなければ削除
If s.Index <> ThisWorkbook.Worksheets.Count Then
s.Delete
End If

Next
Application.DisplayAlerts = True

'保存
ActiveWorkbook.SaveAs Filename:=flname, FileFormat:=xlNormal
'xlsmが良ければ、FileFormat:=xlOpenXMLWorkbookMacroEnabled とする
End Sub

お礼

maverik1226様　
ご回答ありがとうございます。

maverik1226様のコードをそのまま使うと
質問に対する答えがそのまま出てきました。
大変助かりました。

回答No.4

imogasi

＞標準モジュールも含んだファイルを保存するには
があるため（マクロをコピーしてくるようなことはVBAの初級中級のものが、やる課題で無いと思うので）
＃１のお答えに賛成。
（１）ブックをコピー
（２）コピーで出来たブックの名前を望みのものに設定
（３）最終のシートを1つ残して削除
（４）残った１シートのセル内容を消す（必要なら）
ーー
引っかかったのは
＞最終シート
ですシートタブが一番右のシートで良いのか（下記例はこの方）、シート名の名前の上で、日付（の一部）などがシート名の一部についていて、その日付の最終のものなどとなると、コードも増える（変に年を略した月日などにしていると来年分と前後が区別できない）。
心配要らないのかな？
＞マクロの保存ができません
この意味は？。マクロのコードモジュールの別ブックへのコピー法がわからないということか。それを聞いているような質問が昨日今日あったが。
ーー
やっていることは
サブコードｃｃをつけてコピー保存
ソンブックを開いて最後のシート以外は削除
最後のシートとモジュールは残っていることを確認
した。
これで不都合な点はあるだろうか。相当ケースでテストをしてチェックしてください。
Sub test01()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Filename = ThisWorkbook.Name
MsgBox Filename
flnm = Split(Filename, ".")(0)
MsgBox flnm & "cc" & ".xls"
ActiveWorkbook.SaveCopyAs Filename:=flnm & "cc" & ".xls"
Workbooks.Open flnm & "cc" & ".xls"
For Each sh In Worksheets
MsgBox sh.Name
If sh.Index <> Sheets.Count Then
MsgBox sh.Name
sh.Delete
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

お礼

imogasi様
いつもご回答ありがとうございます。

NO.1のご回答と同じくimogasi様の発想方法を
使ってコードを書き直すと私が思っていたことが
できるようになりました。

回答No.3

maverik1226

temtecomai2様

No1の回答を見ず、横ヤリ入れたような形になってしまいました。
申し訳ないです。

回答No.1

temtecomai2

そういうアプローチではなく、
1. ファイル自体を別名でコピーする。
2. 別名でコピーされたファイルを開く。
3. 最終シート以外のワークシートを削除する。
4. 保存して閉じる。
でいいかと。

お礼

temtecomai2様
ご回答ありがとうございます。

ご回答の発想方法を使ってコードを書き直すと
私が思っていたことができるようになりました。