Excel2003VBAでファイルをコピーして指定場所に保存

質問

こんにちわ。
私は下記のコードで保存場所をＣドライブに指定しているのですが、これを保存先が選べるようにするのはどうすれば良いですか？

Application.DisplayAlerts = False
Set OldWkbook = ActiveWorkbook
'
'ファイル名を取得
BkName1 = OldWkbook.Sheets(StName1).Range("E1").Value
BkName2 = OldWkbook.Sheets(StName1).Range("E2").Value
BkName3 = OldWkbook.Sheets(StName1).Range("E3").Value

FileName = BkName1 & Format(".") & Format("試験結果") & Format(".") & BkName2 & Format(".") & BkName3 & ".xls"

FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)

If FileName = "" Then
Exit Sub
Else
If Right(FileName, 4) <> ".xls" Then
MsgBox "ファイル名が異常です。"
Exit Sub
End If
End If

'シートの保護を解除
Worksheets("Sheet1").Unprotect
Worksheets("Sheet2").Unprotect
Worksheets("Sheet3").Unprotect

OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4, StName5)).copy

Set NewWkbook = ActiveWorkbook

'ボタンを削除
For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
NewWkbook.Sheets(1).Shapes(wIx).Delete
End If
Next

NewWkbook.Sheets(1).Name = StName1

'コピー先シートの保護
Sheets(1).Protect
Sheets(2).Protect
Sheets(3).Protect
Sheets(4).Protect
Sheets(5).Protect

FileName = "C:\" & FileName

If Dir(FileName) <> "" Then
'##ファイルが既に存在する
If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then

NewWkbook.Close savechanges:=False

'##保存せずに終了
'シートの保護
Worksheets("Sheet1").Protect
Worksheets("Sheet2").Protect
Worksheets("Sheet3").Protect
Exit Sub
'##指定ファイル置き換え保存
End If
NewWkbook.SaveAs FileName:=FileName
Else
'##ファイルを新規保存
NewWkbook.SaveAs FileName:=FileName
End If

NewWkbook.Close savechanges:=False
Application.DisplayAlerts = True

'シートの保護
Worksheets("Sheet1").Protect
Worksheets("Sheet2").Protect
Worksheets("Sheet3").Protect

End Sub

回答No.5

pkh4989 · ベストアンサー

No3です。
以下のようにしてみてください。

　　Filename = Application.GetSaveAsFilename(Filename, "XLSファイル (*.xls),*.xls", , "保存するデータ(XLS)")
　　If Filename = "False" Then
　　　　'##保存せずに終了
　　　　NewWkbook.Close savechanges:=False
　　　　'シートの保護
　　　　Worksheets("Sheet1").Protect
　　　　Worksheets("Sheet2").Protect
　　　　Worksheets("Sheet3").Protect
　　　　Exit Sub
　　End

お礼

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

回答No.4

imogasi

ファイルの保存に関して
下記をやってみてください。
Sub test01()
Application.Dialogs(xlDialogSaveAs).Show arg1:="C:\Documents and Settings\XXXX\デスクトップ\新しいフォルダ\sample1.xls"
End Sub
上記のarg1:=で
一番指定されそうなフォルダとファイル名を指定するのはどうでしょう。この場合上位フォルダに戻る必要がある場合があるでしょう。
それが手間なら、あるいは
arg1:="C:\Documents and Settings\xxxX\デスクトップ\\sampl.xls"
とすると「デスクトップ」フォルダの一覧が表示され、ファイル名が
samp1.xlsで指定待ちになるようですから、意図するフォルダをクリックすればよい。
ーー
この場合NewWkbook.SaveAs FileName:=FileName
のようなメソッドはコード上に書く必要がなく、ユーザーのダイアロウグの指定とともに、保存が行われるので、注意のこと。
ファイル指定対話（お膳立て）
指定されたファイル名の受け取り
その指定ファイル名での保存
の３つを含んでいると言うことです。
コードがすっきり、引き締まったものになると思います。
ほかに引数もありますので使えないか勉強してください。
http://www.excel7.com/personal/vba_shiryou1.htm
の引数一覧参照。
ーー
Googleで「xldialogsaveas フォルダ指定」で照会すれば記事が出ます。

補足

ご回答ありがとうございます。
まだまだ初心者なのでimogasi様が仰っている意味を完全に理解できていません・・。貼り付けていただいたサイトで勉強してみます。

回答No.3

pkh4989

以下の行を追加して下さい。

Filename = Application.GetSaveAsFilename(Filename, "XLSファイル (*.xls),*.xls", , "保存するデータ(XLS)")
If Filename = "False" Then　　　'←追加
　　Exit Sub　　　　　　　　　　'←追加
End If　　　　　　　　　　　　　'←追加

補足

ご回答ありがとうございます。
ご提示されたコードを追加して実行したところ、キャンセルを選択すると保存はされないのですが、Book1というファイル名が作成されてしまいました。キャンセルを選択したら新しいファイルを作成しないで保存もされないというのを希望しております。

回答No.2

yama1718

この行を入れるのはどうでしょうか？
「保存」を押すとファイル名がフルパスで入ってきますし、
「キャンセル」を押すと False が入ってきます。

Filename = Application.GetSaveAsFilename(Filename, "XLSファイル (*.xls),*.xls", , "保存するデータ(XLS)")

補足

ご回答ありがとうございます。
FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
これを削除して
FileName = "C:\" & FileNameを
Filename = Application.GetSaveAsFilename(Filename, "XLSファイル (*.xls),*.xls", , "保存するデータ(XLS)")に変更したところ、保存できました！しかし、キャンセルした場合にはFalse.xlsというファイル名で保存されてしまいます。キャンセルした場合は保存しないようにしたいのですが可能ですか？

回答No.1

n-jun

フォルダを選択するダイアログ
http://www.officetanaka.net/excel/vba/tips/tips39.htm

を検討されてみては如何でしょうか？

補足

ご回答ありがとうございます。
是非参考にさせていただきます！