エクセル VBA 特定のシートを保存

質問

エクセルファイルで複数シートがある中で特定のシートのみをボタンを押すことで以下の要件を満たした形で別ファイルとして保存したいと思っていますが、何分VBA初心者の自分にはハードルが高く困っています。どうかお助け下さい。
要件
①ファイル名はシート名+（セルW5の数値）
　セルW5の数値はシート１から飛んできている数式
②保存先は任意のフォルダーを指定
③保存後のファイルにはマクロボタンを消去
④拡張子はxlsx形式で保存
高望みだと思いますがどうぞよろしくお願いします。

回答No.4

kkkkkm · ベストアンサー

> ①コピーされたファイルは保存後閉じる（元ファイルはそのまま）
> ②元ファイル同シートのセルE14：X44を削除

コードの最後に以下を追加してみてください。

Workbooks(NewFileName).Close
ThisWorkbook.Sheets(WsName).Range("E14:X44").ClearContents

あと、フォルダ選択のダイアログを開いた時に最初に選択されているフォルダを指定しておいた方がいいのではと思いましたので

mFileName = Application.GetSaveAsFilename(InitialFileName:=NewFileName, FileFilter:="Excelファイル,*.xlsx")
の前に初期のフォルダを指定

フォルダを直接指定する場合(CドライブのOkフォルダとしたら)
ChDir "C:\Ok"

マクロ実行しているブックのフォルダを指定する場合
ChDir ThisWorkbook.Path

以下のような感じになります

ChDir "C:\Ok"
mFileName = Application.GetSaveAsFilename(InitialFileName:=NewFileName, FileFilter:="Excelファイル,*.xlsx")

お礼

度々のお願いにも関わらずご丁寧なご教示大変ありがとうございます。貴重なお時間をいただきありがとうございました。今後ともよろしくお願いします。

Powered by GRATICA

回答No.3

kkkkkm

以下で試してみてください。

Sheet1は実際にコピーしたいシート名を指定してください。

Sub Test()
Dim mFileName As Variant
Dim WsName As String, NewFileName As String

WsName = "Sheet1"

Sheets(WsName).Copy

With ActiveWorkbook.Sheets(WsName)
.OLEObjects.Delete
.Buttons.Delete
End With

NewFileName = WsName & ThisWorkbook.Sheets("シート1").Range("W5").Value & ".xlsx"

mFileName = Application.GetSaveAsFilename(InitialFileName:=NewFileName, FileFilter:="Excelファイル,*.xlsx")
If mFileName = False Then
MsgBox "キャンセルされました", vbInformation
Exit Sub
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs mFileName
Application.DisplayAlerts = True
End Sub

補足

kkkkkmさん
早速のご返答ありがとうございます。
早速試してみたところほぼ希望通りのことが実現でき感動してます。
ちなみに後いくつか質問させていただけると助かります。
それは
①コピーされたファイルは保存後閉じる（元ファイルはそのまま）
②元ファイル同シートのセルE14：X44を削除
以上、甘えついでで申し訳ありませんが対応いただければ幸いです。
よろしくお願いします。

回答No.2

okormazd

Sub save_book()

'オブジェクト変数を使えば1行が短かくなる。vbeの設定によってはModule削除の部分で動かなくなるかも

'保存フォルダー、適当に決める
save_folder = "D:\kokon\tokoro\"
'ファイル名
file_name = ThisWorkbook.Sheets(1).Name & ThisWorkbook.Sheets(1).Range("W5")

'元のブックを保存
ThisWorkbook.Save

'警告表示をしない
Application.DisplayAlerts = False

'シート数を取得
sh_count = ThisWorkbook.Sheets.Count

'sheet1を残して他は削除
For s = sh_count To 2 Step -1
ThisWorkbook.Sheets(s).Delete
Next

'sheet1にある図形を削除
shp_count = ThisWorkbook.Sheets(1).Shapes.Count
For i = shp_count To 1 Step -1
ThisWorkbook.Sheets(1).Shapes(i).Delete
Next

'xlsxで保存するからModule削除
module_count = Application.VBE.ActiveVBProject.VBComponents.Count
For i = module_count To 1 Step -1
If Left(Application.VBE.ActiveVBProject.VBComponents(i).Name, 6) = "Module" Then
Application.VBE.ActiveVBProject.VBComponents.Remove _
Application.VBE.ActiveVBProject.VBComponents(i)
End If
Next i

'希望の状態で保存
ThisWorkbook.SaveAs Filename:=save_folder & file_name, FileFormat:=xlOpenXMLWorkbook

'警告表示復活
Application.DisplayAlerts = True

End Sub

お礼

okormazdさん 早速の回答ありがとうございます。 ぜひ参考にさせていただきます。

Powered by GRATICA

回答No.1

FattyBear

特定のシートのみのデーターを別ファイルにする方法として、そのシートの全列を選択しコピーし、
別の空白のブックのシートの列に貼り付ければ元のシートのデーターがそのままコピーされます。
データーの関連づけもそのままです。データー元のファイルの元のシートの値が反映されます。
但し行の高さは元のシートの値はデフォルトに戻ってしまいます。必要なら修正。
できたファイルは名前を付けて好きなホルダーに保存。
お試し下さい。

お礼

FattyBearさん 早速の回答ありがとうございます。 そういう考え方もあるのですね、ぜひ参考にさせていただきます。

Powered by GRATICA