Excelで指定したフォルダに保存するマクロ

質問

Excel2003で、シートをコピーし別ファイルとして保存したいのですが
保存先のフォルダがネットワーク上にあります。
ファイル名は、指定したセルの値で保存されるようにします。
以下の記述でマクロ実行すると、シートは別ファイル(BOOK1)としてコピーされ
ます。
名前をつけて保存ダイアログが開きますが、そのときにマイドキュメントが開き
ます。

Private Sub CommandButton1_Click()
ActiveSheet.Select
ActiveSheet.Copy
Dim Sname As String, Fname As Variant, Folname As String
Folname = "ネットワーク上フォルダのフルパス"
Sname = Range("O46").Value
If Sname = "" Then Sname = ThisWorkbook.Name
Fname = Application.GetSaveAsFilename(InitialFileName:=Sname,
fileFilter:="Excel(*.xls), *.xls")
If Fname <> False Then ActiveWorkbook.SaveAs Fname
End Sub

そもそもネットワーク上のフォルダを指定することはできないのでしょうか？
マクロに関してはずぶの素人で、上記の記述は過去の質問などを参考に作成しま
したので
どこかに間違いがあるのかも知れませんが、間違いを特定することができません。

お手数おかけし申し訳ありませんが、ご教示のほどよろしくお願いします。

補足として、保存する際にダイアログを開きたい理由は以下の通りです。
・保存先誤り防止（作業者が多数いて、使用するPCも違うため）
・ファイル名誤り防止（同じファイル名が存在しないかどうか確認）

回答No.2

nicotinism · ベストアンサー

こちらでは、IP Address 指定だとファイル名が,"" で括られてしまいましたが
フォルダ名とファイル名が一緒くたになることはありませんでした。Excel2010
UNC名だとうまく行きました。

Sub てすと()
Dim Sname As String, Fname As Variant
Dim oFs As Object
Const FolName As String = "\\サーバー名\共有名\フォルダ名\"

Set oFs = CreateObject("Scripting.FileSystemObject")
If oFs.folderExists(FolName) = False Then
MsgBox FolName & " が見つかりません"
Set oFs = Nothing
Exit Sub
End If

ActiveSheet.Select
ActiveSheet.Copy
Sname = Range("O46").Value

If Sname = "" Then
Sname = ThisWorkbook.Name
End If

Fname = Application.GetSaveAsFilename(InitialFileName:=FolName & Sname, _
fileFilter:="Excel(*.xls), *.xls")

If Fname <> False Then
ActiveWorkbook.SaveAs Fname
End If
Set oFs = Nothing
End Sub

お礼

ご回答ありがとうございます！

完璧でした！ちゃんと指定したフォルダにセルの値で保存することができました！
本当にありがとうございました☆(≧∀≦*)ノ

補足

大変です！
同じファイルの別のシートにコマンドボタンとマクロをコピーしたら使えなくなりました。

コンパイルエラー：プロシージャの外では無効です
というメッセージが出て、
Set oFs = CreateObject("Scripting.FileSystemObject")

この部分の、文頭にチェックが入りました。

同じマクロは、別シートにコピーできないのでしょうか？

回答No.1

tohru999

Folname = "ネットワーク上フォルダのフルパス"
上記を例えば
Folname = "\\192.168.1.1\Folder1\"
にして、

Fname = Application.GetSaveAsFilename(InitialFileName:=Sname,
を
Fname = Application.GetSaveAsFilename(InitialFileName:=Folname & Sname,
に変更

お礼

回答ありがとうございました！
No.2さんの方法で解決できました。
また機会があれば
お願いします(*・∀・)ノ゛

この場をお借りしまして、No.2さんの補足に書きました不具合ですが
ちょっとした操作ミスで発生していたことが判明し、教えていただいた方法で解決できました！
お騒がせし、申し訳ありませんでした。

補足

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

Fname = Application.GetSaveAsFilename(InitialFileName:=Folname & Sname,

この記述だと、ファイル名にフォルダ名がプラスされてしまいます。
できれば、保存するファイル名はセルの値だけにしたいのですが可能でしょうか？