【VBA】シート順番に新規ブックにコピーする方法

質問

いつもこちらの識者の皆様にはお世話になっております。
VBAのことで質問させてください。

ブックに、
"入力用","りんご","ばなな","みかん"
のシートがあります（シートは今後増える可能性があります）

このうち、"入力用"以外のシートに下記の処理をしたいのです。

1.1シートごとに新規でブックを作成し、データを値で貼り付ける。
2.ファイル名を"シート名" + mmdd形式でC:\aaa\に保存する（ex.C:\aaa\りんご0513.xls）
　このときできれば、シートはコピーしてきた1つだけにするのが望ましいです。

作りかけのコードは下記です。

--------------------------------------------------------------
Sub test()

Dim objSh As Object

For Each objSh In ActiveWorkbook.Sheets
If objSh.Name <> "入力用" Then
objSh.Select
ThisWorkbook.ActiveSheet.Copy '関数が残っているので値で貼り付けたい
ActiveWorkbook.SaveAs Filename:="" 'コード不明
End If
Next

End Sub
--------------------------------------------------------------

分からない点は
1.ThisWorkbook.ActiveSheet.Copyで新規ブックにシートをコピーすることはできたのですが、
関数が残ってしまっているので、値で貼り付けたい。
2.シート名を取得して、ファイル名に反映する方法がわからない。
です。

どなたか、上記内容の場合どのようなコードが適しているか教えていただけませんでしょうか。
よろしくお願いいたします。

回答No.5

keithin · ベストアンサー

回答No.３ですが、回答したマクロに誤記がありました。ごめんなさい。その他下記に差し替えておこなってください。

sub macro1r1()
　dim w as worksheet
　application.screenupdating = false
　for each w in activeworkbook.worksheets
　　if w.name <> "入力用" then
　　　on error goto errhandle
　　　w.copy
　　　on error goto 0
　　　activesheet.usedrange.value = activesheet.usedrange.value
　　　'下記一行誤記訂正。いわずもがなですが「正しい保存場所」にマクロを修正の事
　　　activeworkbook.saveas filename:="C:\aaa\" & activesheet.name & format(date, "mmdd") & ".xls"
　　　activeworkbook.close
retpos:
　　end if
　next
　application.screenupdating = true
　exit sub

errhandle:
　resume retpos
end sub

で。
＞w.copyのところでエラー

単純なシートのコピーができない？
マクロのせいだとはあんまり考えにくいです。

＞このうち、"入力用"以外のシートに下記の処理をしたいのです。

たとえば「非表示にしたシート」がブックに含まれているとかかもしれません。

お礼

何度も投稿いただきありがとうございます。
おかげさまで解決いたしました。

補足

仰るとおりでした！
非表示にした"data"シートがありました。
正しくは
"入力用"と"data"シート以外のシートに下記の処理をしたいのです。ということになります・・・

回答No.6

keithin

＞正しくは"入力用"と"data"シート以外のシートに下記の処理をしたいのです

回答No5で既に対処済みですが？
(もっとも，あまりお薦めできる対処ではありませんでしたが）

敢えて「入力用とdataを除外」とだけ限定したいのでしたら，No.3のマクロをその旨修正するだけでも構いません。
if w.name <> "入力用" and w.name <> "data" then

お礼

No.3で既にできていました。
失礼しました。
そして複数条件の場合も教えていただきありがとうございます。

回答No.4

K Kazz（@JazzCorp）

'シート（指定されたものを除く）をコピーし、それぞれ名前を変更してブックで保存する
Option Explicit
Sub CopySheetsEachBooks()
'Const xPath0 = "d:\tmp\"
Const xPath0 ="C:\aaa\"
Const xExcept = "入力用"
Const xMode = False
Dim xSheet As Worksheet
Dim xPath As String
Dim xName As String
Dim xExtent As String
Dim xLast As Long
Dim nn As Long
Debug.Print vbNewLine & Now & " ：Here We 5！"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xExtent = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
If (xPath0 = Empty) Then
xPath = (ThisWorkbook.Path & "\")
Else
xPath = xPath0
End If
For Each xSheet In ThisWorkbook.Sheets
If (xSheet.Name <> xExcept) Then
'引数を省略すると、新規ブックが自動的に開いてシートだけがコピーされ、新規ブックがアクティブになる。当然、シートはソレだけ、、、
xSheet.Copy
ActiveSheet.UsedRange.Clear
Application.CutCopyMode = False
xSheet.UsedRange.Copy
With Range("A1")
' .PasteSpecial xlPasteValuesAndNumberFormats
'Excel2000はコォ～なっちゃう、、、
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
'ブック名を変更して保存
ActiveWorkbook.SaveAs Filename:=(xPath & xSheet.Name & Format(Date, "mmdd") & xExtent)
ActiveWorkbook.Close
End If
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。
難しいコードがたくさんあるので自分でも勉強してみます！

回答No.3

keithin

シートをコピーし
値に直して（＊）
名前を付けて保存する

＊：書式のみ用意した空の雛形シートを用意できていれば、雛形シートのコピー＆値転記の手順にできます。
＊：実は「入力用」シートにリンクする数式だけを値化すればよいだけなら、別の考え方もありますが今回はとりあえずそれは考えない事に。

sub macro1()
　dim w as worksheet
　application.screenupdating = false
　for each w in activeworkbook.worksheets
　　if w.name <> "入力用" then
　　　w.copy
　　　activesheet.usedrange.value = activesheet.usedrange.value
　　　activeworkbook.saveas filename:="C*\aaa\" & activesheet.name & format(date, "mmdd") & ".xls"
　　　activeworkbook.close
　　end if
　next
　application.screenupdating = true
end sub

お礼

何度も投稿いただきありがとうございます。
おかげさまで解決いたしました。

補足

ありがとうございます。
このコードですとw.copyのところで
実行時エラー'1004':
'Copy'メソッドは失敗しました:'_Worksheet'オブジェクト
と出てしまいます。
何かこちらで指定してないことなどありましたでしょうか。

回答No.2

mt2008

手抜きのサンプルです。
保存前に同名ファイルの有無位はチェックした方が良いかな。

Sub test()
　　Dim objSh As Object
　　For Each objSh In ActiveWorkbook.Sheets
　　　　If objSh.Name <> "入力用" Then
　　　　　　objSh.Copy
　　　　　　Cells.Copy
　　　　　　Cells.PasteSpecial Paste:=xlPasteValues
　　　　　　Range("A1").Select　　　　　　
　　　　　　ActiveWorkbook.SaveAs Filename:="C:\aaa\" & objSh.Name & Format(Now(), "MMDD") & ".xls"
　　　　　　ActiveWindow.Close
　　　　End If
　　Next
End Sub

お礼

ありがとうございます。
↓の方の補足欄にも記入しておりますが、シートにはそれぞれ書式が設定されており、その書式は生かしたいのです。
説明不足で申し訳ありません。

回答No.1

gt-t

こんにちは、こんな感じで。

Sub qa8085962()
　Dim lSNW As Long
　Dim wbN As Workbook
　Dim wsC As Worksheet
　Dim strFPath As String
　Dim strD As String

　lSNW = Application.SheetsInNewWorkbook '現在の新規bookのシート数を確認
　strFPath = "C:\aaa" '保存先
　strD = Format(Now(), "MMdd") '今日の日付をMMDDに
　Application.SheetsInNewWorkbook = 1 '新規bookのシート数を1に変更

　For Each wsC In ThisWorkbook.Worksheets
　　If wsC.Name <> "入力用" Then
　　　Set wbN = Workbooks.Add
　　　wsC.Range(wsC.Range("a1"), wsC.UsedRange.Address).Copy
　　　wbN.Worksheets(1).Range("a1").PasteSpecial Paste:=xlPasteValues
　　　wbN.SaveAs Filename:=strFPath & "\" & wsC.Name & strD & ".xls", FileFormat:=56 'FileFormatはexcel2007以降用
　　　wbN.Close
　　　Set wbN = Nothing
　　End If
　Next

　Application.SheetsInNewWorkbook = lSNW '新規bookのシート数を元に戻す

End Sub

お礼

シート名の取得はnameプロパティを使えばよかったんですね。
自分でも使っていながら気づきませんでした。ありがとうございます。

補足

失礼しました。
私の説明が悪かったです。
シートにはそれぞれ書式が設定されており、その書式は生かしたいのです。
ThisWorkbook.ActiveSheet.Copy
で、新規ブックにペーストしてから、それを値に直す方法はありますでしょうか。

そして、excelのバージョンもお伝えしておりませんでした。
Excel2003になります。