エクセルで特定のシートだけを別ファイル名で保存

質問

いつもお世話になっております。
作業用の既存Bookの特定のシート（提出用）だけを、別のファイル名で保存したい。
保存先フォルダーはフルパスで指定して、ファイル名は当該シートの指定セルの内容で、xlsx形式で保存したいのです。

過去の質問に似たようなケースの回答があるのですが、悲しいかな使いこなせないレベルなのでHELPさせていただきます。

回答No.7

kkkkkm · ベストアンサー

NewBookNameが問題でしたら
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & NewBookName
でエラーになると思います。

エラーの個所とエラーメッセージが曖昧なのでよくわかりませんが

.Cells.Copy
With Workbooks(NewBookName).Sheets("提出用")
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

もしくは

With Workbooks(NewBookName).Sheets("提出用")
.Cells.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

に変更してみてください。

エラーの個所が反転せずにエラーメッセージが出た場合
F8キーを押してステップ実行で一行ずつ実行させてエラーの出る箇所を特定してください。

お礼

何度もありがとうございました。
本当に助かりました。
保存時に全部のシートに保護がかかることを伝えるのを忘れていました。
このレベルにお付き合いくださり感謝いたします。

補足

こんばんわ。
朝8時前のご回答非常に申し訳なく。

先ずはご報告です。
うまくいきました！！！！！！！

夢中で試行錯誤していると知らぬ間にBook24とかまで開いていてオブジェクトエラーが出ます。

とにかく訳も分からずNo2の修正でうまくいきました。
いつもなら諦めるところでしたが、励ましのおかげもあり何とかなりました。

F8でその都度何度も確認しましたが、止まるところは、NewBookNameではなく、
Application.CutCopyMode = False
でのエラーだったようです。

昨日はNewBookNameと既存のコードをとっかえひっかえしていましたので、今となっては、ある意味ここが原因でしたが？

月曜日に本物のシートで確認してBSでCloseさせていただきます。
もう少しお付き合いくださいませ。(トラブることがないように祈っていてください）

回答No.10

kkkkkm

何らかの要因で新規ブックがアクティブでなくなりSelectでエラーというのもあるかなという気がしたので
.Range("A1").Select
の前に.Activateを入れて
.Activate
.Range("A1").Select
としてみるとどうでしょう。

お礼

本当に最後まで見放さずにお付き合いいただき大感謝です。
今週中には５つのBookを対象に実際に使い始めて、報告書として送付される予定です。

補足

お手数をおかけしました。

今回は当方の知識不足ゆえの検証不備があり、非常にお手数をおかけしてしまいましたが今会社で確認し期待通りの動きを確認しました。

トラブった原因は大きく２つ。
１．失敗して次の試行時に途中で作成されているBookを削除せずに次の試行をしてしまう。（前半の原因）
２．元シートに保護がかかっているので貼り付け時にエラーとなる。
恐らく２が最大のトラブル原因だったと思われます。

元ファイルには保存時に入力セルにだけ保護がかかるようにマクロが設定されていたので,何度も試行するうちにはセル値を変えたりするのに保護を外したまま試行すると動くのに、一旦保存すると再度同じエラーになってしまって、「全く訳分らん！」状態で気づくのが遅れました。
色々やりすぎて順列組み合わせの正解がどれか分からなくなってパニック状態。
出来そうでできないので余計イライラ・・・

適当な場所にunprotectを挿入して解決できました。

回答No.9

HohoPapa

ごめんなさい、直します。
Sub Test13()

　Dim NewBookName As String
　Dim TgCell As Range

　'保存先ファイル名（フルパス）を組立
　'指定シートだけで新たなブックを生成
　'新たなブックを仮保存
　With ThisWorkbook.Sheets("提出用")
　　'NewBookName = _
　　　"\\Srv01\原紙" & "\" & Range("F6") & Range("A1").Value & ".xlsx"
　　NewBookName = _
　　　 Range("F6") & Range("A1").Value & ".xlsx"
　　.Copy
　　ActiveWorkbook.SaveAs Filename:=NewBookName
　End With

　'新たなブックの関数式を値に書き換え
　With Workbooks(NewBookName).Sheets("提出用")
　　.Unprotect
　　For Each TgCell In .UsedRange　　'<==修正後
　　　TgCell.Value = TgCell.Value
　　Next TgCell
　End With

　'新たなブックを最終保存して閉じる
　Workbooks(NewBookName).Save
　Workbooks(NewBookName).Close

End Sub

お礼

いつもお世話になっております。

修正版までいただき恐縮です。
が何度やっても非常に時間がかかり最後はエクセルが止まってしまいます。
（あるいはあっさり見慣れた「オブジェクトエラー」と表示されますが、これは前回の試行時で自動で作られるBookが表示されている場合だと思います。（今回混乱した原因）

そこでF8でステップを追ってみると下記の2行を行ったり来たりします。
念のため、かなりしつこくF8を押してみましたが行ったり来たりを繰り返しました。

TgCell.Value = TgCell.Value
Next TgCell

今回はNo7さんのg回答で解決できました。
検証が遅れたため、お手数をおかけしてしまいました。

補足

今回は最初にご回答いただいたkkkkkmさんのご回答で解決できました。

今回大きくトラブった原因は下記の２点。
１．いったん失敗した後の試行では前回のBookが残っているのでエラーとなる。
２．シートには保存時に自動で保護かかるようにマクロが設定されているのでコピペの貼り付時に、シートの保護の状況で結果が変わる。これが最大の原因。

そこで、念のためにご回答の改良版を最後に試してみましたが、やはり結果は同じ個所でエラーとなりました。

恐らくまだ当方に見落としがある思われますが今回は疲れたのでここまででご容赦！！

ありがとうございました。

回答No.8

HohoPapa

私だったらコピー＆ペースト（クリップボード経由）を使わず
以下のように
単なる値複写のコードで数式から値に置き換えます。

Sub Test12()

　Dim NewBookName As String
　Dim TgCell As Range

　'保存先ファイル名（フルパス）を組立
　'指定シートだけで新たなブックを生成
　'新たなブックを仮保存
　With ThisWorkbook.Sheets("提出用")
　　NewBookName = _
　　　"\\Srv01\原紙" & "\" & Range("F6") & Range("A1").Value & ".xlsx"
　　.Copy
　　ActiveWorkbook.SaveAs Filename:=NewBookName
　End With

　'新たなブックの関数式を全数値に書き換え
　With Workbooks(NewBookName).Sheets("提出用")
　　.Unprotect
　　For Each TgCell In ActiveSheet.UsedRange
　　　TgCell.Value = TgCell.Value
　　Next TgCell
　End With

　'新たなブックを最終保存して閉じる
　Workbooks(NewBookName).Save
　Workbooks(NewBookName).Close

End Sub

回答No.6

kkkkkm

Sheets("Sheet1").Select
がコピーした先の新規ブックのシートだと明示していないために元のシートが変更されたのだと思います。

ブックをまたぐ操作の場合ブック名を指定しないと意図しないシートを操作してしまう事になります。
同じように複数のシートでセルを操作する場合もシート名を指定した方がいいと思います。

もとのコードを直すのは厳しいので(私流にしました)

Sub Test()
With ThisWorkbook.Sheets("提出用")
.Copy
.Cells.Copy
With ActiveWorkbook.Sheets("提出用")
.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Range("A1").Select
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & .Range("A1").Value & ".xlsx"
End With
End Sub

上記だと最後までActiveWorkbookという不確定な要素があるので不安だという場合、.Copyのあとで即保存してブック名を確定し、以後ブック名で操作したものが以下です。

Sub Test2()
Dim NewBookName As String

With ThisWorkbook.Sheets("提出用")
NewBookName = .Range("A1").Value & ".xlsx"
.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & NewBookName
.Cells.Copy
With Workbooks(NewBookName).Sheets("提出用")
.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Range("A1").Select
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Workbooks(NewBookName).Save
End With
End Sub

補足

こんばんわ。
まだやってます。
No1でもNo2のコードでも、コピを取ってセル名でパスで指定したフォルダいｎ保存されることは確認しまし。
が、.Cells.Copy以下の数値貼り付けの部分を入れると「・・オブジェクトのエラー」となります。

下記の部分を削除すれば、期待通りに動くので、問題になりそうな部分は(NewBookName)だけだと思い、.Range("A1").Value & ".xlsx"　や実際のパスをれてThisWorkbook.Path & "\" & NewBookName　等々色々試してみたのですがダメでした。
「 NewBookName」のままと、「.Range("A1").Value & ".xlsx"」　も試してみましたが同じ結果でした。

質問が理解されないレベルかと思いますが、何かアドバイスお願いします。

.Cells.Copy
With Workbooks(NewBookName).Sheets("提出用")
.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
.Range("A1").Select
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Workbooks(NewBookName).Save

回答No.5

imogasi

似たような質問をする人が多いが、ポイントは２つ。
（１）特定のシートだけを別ファイル名で保存
の操作はVBAでもエクセル操作（メニュー）でもないと思う。
標題にVBAの質問かどうか」を書け。本件はマクロの記録でも済みそうだが。
（２）だから新規ブックを作り、その１シートに元の１シートをコピーして貼り付けする。そして新規ブックの方を、名前を付けて保存する。
（３）元の１シートをコピーと俗に言うが、代入とコピーの違いを意識できているか。
　（A)セルの値だけで十分な場合は、セルの値の代入
　（B)セルの値はもちろん、表示形式や、数式やコメントがあればそれも含めて
持って行きたいときは、コピーを使う。数秒だろうが時間をくう。
ExcelVBAをやるのだろうが、シートは（A)セルの値（B）数式（C)表示形式（D)入力規則（E)コメント
などが、別レイヤー的に、重畳的になっていることを分かっているのかな。
そしてそれらのどこまでをもんだいにするのか。

お礼

最初のご回答で何とかなりそうで、そちらに気がいてしまい、結局長々とかかってしまったのでお礼が遅くなりました。

ありがとうございました。

回答No.4

kkkkkm

> 昼前から何度もTry＆Errorの結果下記で完成できました。

できてよかったですね。ある程度できている場合、実際のコードを記載したほうが回答者はわかりやすいかもしれません(同じ動作でも人によってコードは違ったりしますので)
ただ、中にはばっさり変更(回答者好みのコードにする)して回答する方もいらっしゃいますから、ある意味落ち込むかもしれませんが…。

補足

イヤ～ちょうど参っていたところです。
さすがに再度の質問を立てるに気が引けて、昼から他の仕事もそこそこにかかりっきりで格闘するもお手上げ状態.
で諦めかけて一応ここをのぞいてみたらアドバイスが入っていたので、厚かましくも恥ずかしくも追加です。

元シートを新規Bookに張り付けたまま提出すると、顧客に各種係数やら計算式が見えてしまうので一旦コピーして数値で貼り付ける必要があります。
そして保存前に保護をかけたい。誤操作防止なのでパスワードは設定不要。
但し、元のシートには保護がかかっているので、新規Bookに張り付けたシートにも保護がかかっている状態です。

色んなパターンでマクロの記録を駆使？して、ご回答のコードに挿入してみて、一旦はできた！と思い即お礼をアップしたのですが、よくよく見ると何度やっても保存まで出来た場合、(1)数値貼り付けになっていない、(2)元シートが数値貼り付けになってしまっている。
(2)の場合は保存したファイルはうまく行ったように見えるのですが元シートの式やリンクが数値になってしまていました。
の２パターンから改善できません。

下記は元シートを同じBookのSheet１に張り付けて、再度コピーして数値で貼り付けて最後に保護をかけた場合のコードです。
これをご回答の .Copyででできたシートに追加したいのですが。
いろんなパターンで記録して挿入しまたが健闘（検討）」むなしく状態。

当方、このレベルですのでバッサリでも落ち込むことは全くないので何とかならないでしょうか？
お助けあれ!！！！！

Sub コピペ数値貼付()
'
Cells.Select
Selection.Copy
Cells.Select
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

回答No.3

kkkkkm

Filename:=以降はご自身の環境に合わせて変更してください。
ThisWorkbook.PathはVBAが実行されていて保存していないブックだとエラーになります。テスト的に開いたBookにVBAを記載し未保存の状態で実行するとエラーです。別フォルダに保存する場合ThisWorkbook.Pathは本来のフルパスを指定してください。

Sub Test()
With ThisWorkbook.Sheets("提出用")
.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & .Range("A1").Value & ".xlsx"
End With
End Sub

お礼

出直してよかったです。

確かに昨日の質問では「保存のコードを教えて」みたいになっていました。
当方としては、最初に、(1)新規Bookに(2)書式はワード風で(3)係数や式は数字で貼り付けて(4)自動保存したい、と考えたので(3)まで出来たのですが。。。と余計な説明を入れてしまったのが失敗でした。

.Copyで一発だったのですネ。

ほぼ毎日、多い日には３回位この作業をしますので本当に助かりました。

補足

早々、かつ見放さずに面倒を見ていただき感謝！！！
昼前から何度もTry＆Errorの結果下記で完成できました。

また、「数値貼り付け」だの「シートの保護」といった要求が抜けておりましたが何とか自力で追加できました。（さすがに追加はしにくかったので頑張りました）

Sub 転記保存()
With ThisWorkbook.Sheets("提出用")
.Copy

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

ActiveWorkbook.SaveAs Filename:="\\Srv01\原紙" & "\" & Range("F6") & Range("A1").Value & ".xlsx"

End With
End Sub

回答No.2

Nobu-W

https://iinamotto.com/2013/12/1663.html
解説で操作画像付きです　手順通りやってみて下さい
最後の
『新しいブックにワークシートが移動しました。これを保存すれば別のファイ
　ルになります。』
上記作業の時保存先フォルダ～をフルパスで指定して、保存して下さい

参考URL：

https://iinamotto.com/2013/12/1663.html

お礼

早々のご回答ありがとうございました。

昨日の質問の続きというか、質問が意味不明とのご指摘があったので、同じ質問の出直し質問で、上記の操作のマクロ化が目的でした。

同じ質問の出直しだったため、つい「作業をマクロ化したい」旨抜けてしまっていました。
つきましては、大変お手数をおかけしたことお詫びします。

回答No.1

bardfish

新規のエクセルファイルを作成して保存。

提出用シートのあるエクセルファイルを開いて目的のシートを「移動またはコピー」で新規に作ったエクセルファイルにコピーする。
そしてコピー先のエクセルファイルで不要なシートは削除。
ファイル名は適時変更してください。

ではいかがでしょうか？

お礼

早々のご回答ありがとうございます。

保存の手前まではマクロで自動に出来るので、そのVBAで作成されたBookを自動で、ファイル名をセルから取得して保存するコードを知りたかったのです。

お手数をおかけしました。