エクセルのマクロについて教えてください。

マクロコードについて教えてください。
下記はExcelファイルをセルDF1値のファイル名にて指定フォルダー内に保存するコードですが
Sub 紙保存()
Application.GetSaveAsFilename InitialFileName:="\\nas-sp01\share\○○部\○○\○○\○○班用\★★★○○申請\" & Range("CF1 ").Value
End Sub
指定フォルダーを示して、
名前を付けて保存が立ち上がり、ファイル名も自動で表示されて
最後に「保存（S）をクリックしても
指定フォルダー内に保存されません。
何も保存されない状態です。
コードに問題があるのでしょうか？
以前、指定フォルダーを設定しないコードの時は
Sub 青紙保存()
Application.Dialogs(xlDialogSaveAs).Show Arg1:=Range("CF1 ").Value
End Sub
は自分で指定してフォルダー内に保存出来てました。
解決方法を教えてください。
よろしくお願いいたします。
尚、ファイルには1～22までのシートがあります、このファイル全体を保存したいです。
よろしくお願いいたします。

質問者からの補足コメント

• 

  回答ありがとうございます。
  貴殿のご指示通りに
  Application.Dialogs InitialFileName:="\\nas-sp01\～
  に設定をしましたが、
  エラーが出てしましました。
  申し訳ありませんが対処方法を教えてください。
  尚、私の都合で申し訳ありませんが、
  本日、これから地方に出かけますので確認は明日の朝以降になると思います。
  よろしくお願いいたします。

  No.1の回答に寄せられた補足コメントです。 補足日時：2022/01/11 17:31

• 

  ご連絡が遅くなり、申し訳ありませんでした。
  上手く設定が出来ました。
  しかし同じ、コードをコピーして
  下記のように少し内容を変更した場合ダイアログボックスを表示の「ファイル名」に何も表示が無く
  空白になってしまいます。

  No.2の回答に寄せられた補足コメントです。 補足日時：2022/01/12 12:31

• 

  Sub 電子保存()
  Const folder As String = "\\Nas-sp01\share\～\"
  Dim newName As Variant
  Dim initName As String
  initName = folder & Range("CF1").Value
  newName = Application.GetSaveAsFilename(InitialFileName:=initName, FileFilter:="Excel マクロ有効ブック(*.xlsm), *.xlsm")
  If newName = False Then Exit Sub
  ThisWorkbook.SaveAs (newName)
  End Subのコードです。問題がありますでしょうか？

    補足日時：2022/01/12 12:38

• 

  回答ありがとうございます。
  指定フォルダー以外に
  initName = folder & Range("CE1").Value
  を変更しております。何度かか、マクロを削除し、作成し直したり
  ファイル名を変更して保存し直したり、しましたが、指定フォルダーのダイナログは間違いなく開くのですが、ファイル名にセルCE1値が表示されません
  新しいファイル「テスト」で「紙保存」「電子保存」のマクロを作成しまして実行しましたが
  やはり、紙保存では指定フォルダが開き、セルCF1値の名前が表示されますが、電子保存を実行した場合は、元データーと同じ状況で、ダイナログで指定フォルダには行きますが、やはり、ファイル名にセル値CE1が表示されません、何か問題があるのでしょうか？
  何度も申し訳ありません、よろしくお願いいたします。

  No.4の回答に寄せられた補足コメントです。 補足日時：2022/01/12 14:20

• 

  回答ありがとうございます。問題点が解ったように思います。紙保存のマクロを使用しセルCFとCE1とで試してみるとそれぞれ上手くフェイル名が表示されます。電子保存先の指定フォルダに問題があるのでしょうか？ワードにそれぞれの指定フォルダを保存して紙保存指定フォルダををクリックすると
  「share」からフォルダ名が始まりますが、電子保存の指定フォルダをクリックすると「ネットワーク　share」となります。この違いではないかと思いますが、指定フォルダを選択する時はお内容にコピーをしているのですが、shareの前にネットワークがあるのが問題だと思いますが、
  どうすればよいでしょうか？こちら側のPCの設定の問題でしょうか？
  申し訳ありません、よろしくお願いいたします。

  
  No.5の回答に寄せられた補足コメントです。 補足日時：2022/01/12 15:35

• 

  何度もありがとうございます。ご指示の通り、initName = folder & Worksheets("Sheet7").Range("CF1").Value又はinitName = folder & Worksheets("建築物（表面5.3").Range("CF1").Valueと実際のシート名にしましたがどちら新しいコード部分が黄色くエラーになってしまいます。
  両方のフォルダ先を調べた処、紙保存のフォルダ名が長い為、ネットワークが画面に表されないだけの様です。困りました。何が原因なのかがさっぱりわからなくなってしまいまして・・・よく使うマクロは電子保存なのでこれだけでも上手くいけばよいのですが。
  よろしくお願いいたします。

  No.6の回答に寄せられた補足コメントです。 補足日時：2022/01/12 16:00

• 

  多くの回答ありがとうございます。initName = folder & "ABCD"ですが全く何も表示されませんでした。又、①②ともエラーが出てしまい。黄色くなります。initName = folder & Worksheets("建築物(表面)5.3").Range("CE1").Value　シートですが「建築物(表面)5.3」のシートにセルを合わしてマウスの右クリックをし、「コードの表示を表示すると「Sheet7（建築物(表面)5.3）」のところを示します。紙保存も同じシートなのですが・・やはり、こちら側の問題でしょうか？
  よろしくお願いいたします。

  No.9の回答に寄せられた補足コメントです。 補足日時：2022/01/12 16:51

• 

  お世話になっております。ダイナログ表示無のコードを設定するとCE1値でのファイル名で自動保存されました。
  試しに、Sub 電子保存()
  Const folder As String = "\\nas-sp01\share\○○部\○○\○○\○○班用\★★★○○申請\"
  Dim newName As Variant
  newName = folder & Range("CF1").Value & ".xlsm"
  ThisWorkbook.SaveAs (newName)
  End Sub　ダイナログが問題なのでしょうか？
  よろしくお願いいたします。本日、これからパソコンから離れてしまします。勝手申しますが、確認を明日の朝以降となります。もぅしわけ有りません。

  No.8の回答に寄せられた補足コメントです。 補足日時：2022/01/12 17:05

• 

  ありがとうございます。相当に詰まってまして・・色々回答していただけているのに上手くいかず、どうしてよいかが検討が付きません。紙保存では上手くいくのに電子保存で指定フォルダを変更すると上手くいかないんです。貴殿の助言を参考にさせて頂こうと思いますが、全てのコードを教えて頂けますでしょうか？申し訳ありません、よろしくお願いいたします。

  No.10の回答に寄せられた補足コメントです。 補足日時：2022/01/12 17:26

• 

  おはようございます。数日前より数多くの回答をありがとうございます。今回のシートのコピペでもやはり上手くいきませんでした、ダイヤログを表示させる目的はコード設定した指定フォルダ「\\Nas-sp01\～\1.受付\」最後の受付フォルダの中に物件ごとのフォルダがあり、保存する場合にその物件ごとのフォルダ内に保存をする事が目的です。（この物件フォルダは日々変更されますので）現状の方法として、貴殿から教えて頂きました、ダイヤログを表示させない方法では\1.受付\内にCE1値のファイル名で保存されますので、その後、そのファイルを物件ごとに移動する方法があります。当面はこの方法でやっていきたいと思いますが、今回の内容で別案がありましたらお願いできますでしょうか？何度も申し訳ありません、補足回数も後1回になってしまいました。よろしくお願いいたします。

  No.14の回答に寄せられた補足コメントです。 補足日時：2022/01/13 10:00

No.15 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/01/13 10:51

>当面はこの方法でやっていきたいと思いますが、今回の内容で別案がありましたらお願いできますでしょうか？

申し訳ありませんが別案は思いつきません。
1点、気になるのは、Sub 電子保存()で上手く行かないのは、
InitialFileNameとFileFilterの指定が何かおかしいからと個人的には思っています。
念の為、以下の作業をトライしていただけませんでしょうか。
それでだめな場合は、ギブアップになります。
１．うまくいっているSub 紙保存()をそのままコピーしてSub 電子保存()
を作成。
２．Const folder As String="○○"の個所を、
「ダイナログ表示無のコードを設定するとCE1値でのファイル名で自動保存された」ときのフォルダー名をコピペして、○○へ貼り付ける。
（必ずコピペで行ってください）（うまく保存できた実績のあるフォルダー名です）
３．セルの位置をCF1からCE1に変更する。
（どちらが正しいのか私は判断できません。あなたの判断で正しいセル位置をしてしてください）
４．上記のマクロを実行する。
（FileFilterはSub 紙保存()をコピペするので、上手く行っている実績のあるものをそのまま使うことになります。）

この回答へのお礼

数日間にわたり回答ありがとうございました。大変お手数をお掛けして申し訳ありませんでした。貴殿の最後の回答で設定すると上手くいきましたが、何故か、電子保存先のフォルダ指定をするとファイル名が表示されません、やはり、システム側の関係かもしれません。本当にありがとうございました。
後日、類似の質問をさせて頂こうと持ってます。もしよろしければ、又、お付き合いをお願い致します。

お礼日時：2022/01/13 11:55

No.14 回答者： tatsumaru77 回答日時： 2022/01/13 07:49

＞お世話になっております。

ダイナログ表示無のコードを設定するとCE1値でのファイル名で自動保存されました。

現状、上記の方法しかないようなので、その方法で妥協できませんでしょうか。
１つ疑問なのですが、そもそも、ダイアログを表示するのは何のために行っているのでしょうか。
①表示されたファイル名をオペレータが変えて、変えたファイル名で保存することがあるから。
②表示されたファイル名でOKかどうかをオペレータに確認してほしいから。

①であれば、CF1のセルを直接変えれば済むことです。
②であれば、メッセージボックスを表示すれば代用可能です。

No.13 回答者： tatsumaru77 回答日時： 2022/01/13 07:36

Worksheets("○○").Range("CF1").Valueの

○○の個所がなにか間違っている可能性があります。
○○は手で直接打ち込むのではなく、コピペして貼り付けてください。

「建築物(表面)5.3」のシートのタグにマウスカーソルを合わしてマウスの右クリックをし、「名前の変更」を選択すると、そのシート名が編集状態になります。そのシート名をコピーしてください。
Ctrl+C　でコピーできます。（CtrlキーとCキーを同時に押下）
それを貼り付けてください。

No.12 回答者： tatsumaru77 回答日時： 2022/01/13 07:23

①initName = folder & Worksheets("Sheet7").Range("CF1").Value

②initName = folder & Worksheets("建築物（表面5.3").Range("CF1").Value
で、①の指定はできません。
添付の画像を参照ください。赤線で囲んだシート名は、Worksheets("○○")
として使用不可です。使用できるのは、青線で囲んだシート名です。

No.11 回答者： Qchan1962 回答日時： 2022/01/12 18:37

Application.Dialogs(xlDialogSaveAs).Showはネットワークフォルダを初期指定できない。

GetSaveAsFilenameは取得なので初期ファイル名を指定することは出来ませんでした。
なので＃10の代替え案か、WindowsAPIで作るか・・
WindowsAPIの例　作成が面倒だったので下記サイトから引用し変更
参考サイト　http://hanatyan.sakura.ne.jp/vb6/dialogue02.htm

取り合えず同じ標準モジュールに

Option Explicit

Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long '構造体のサイズ
hwndOwner As Long '親ウィンドウのハンドル
hInstance As Long 'モジュールのインスタンスハンドル
lpstrFilter As String 'VBのファイルパターン
lpstrCustomFilter As String 'カスタムフィルター
nMaxCustFilter As Long '同バイト数
nFilterIndex As Long 'フィルターのインデックス
lpstrFile As String 'フルパス名を受取るバッファー
nMaxFile As Long '同バイト数
lpstrFileTitle As String 'ファイル名を受取るバッファー
nMaxFileTitle As Long '同バイト数
lpstrInitialDir As String '初期ディレクトリ名
lpstrTitle As String 'ダイアログボックスのキャプションタイトル
flags As Long '動作を指定する定数の組合せ
nFileOffset As Integer 'フルパス中のファイル名までのオフセット
nFileExtension As Integer '同　拡張子までのオフセット
lpstrDefExt As String 'デフォルトの拡張子
lCustData As Long 'フックプロシージャに渡すデータ
lpfnHook As Long 'フックプロシージャOFNHookprocへのポインター
lpTemplateName As String 'テンプレートリソース名
End Type
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_EXPLORER = &H80000
Public Function myDialogSaveAs(fol As String, strFileName As String)
'ファイルを保存ダイアログボックスを表示する
Dim tOpenFileName As OPENFILENAME
Dim lngRet As Long
With tOpenFileName
.lStructSize = Len(tOpenFileName)
.hInstance = 0& 'App.hInstance '不要の時　0&
.lpstrFilter = "Excelファイル(*.xls*)" & vbNullChar & "*.xls*"
'優先的に表示させるフィルターのインデックス
.nFilterIndex = 1
'ファイル名の内容を初期化
.lpstrFile = strFileName & String$(256, Chr$(0))
.nMaxFile = 256
'ファイル名を受取るバッファーの設定(Nullで埋めておく)
.lpstrFileTitle = String$(256, Chr$(0))
.nMaxFileTitle = 256
'デフォルトのフォルダー名の設定
.lpstrInitialDir = fol
'ダイアログのキャプション名
.lpstrTitle = "名前を付けて保存"
.flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or _
OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT
End With
lngRet = GetSaveFileName(tOpenFileName)
If lngRet = 0 Then
strFileName = ""
Exit Function
Else
strFileName = Left$(tOpenFileName.lpstrFile, _
InStr(tOpenFileName.lpstrFile, vbNullChar) - 1)
End If
myDialogSaveAs = strFileName
End Function

Sub Create_NewFile() '実行プロシージャ
Dim saveFilePath As String
saveFilePath = myDialogSaveAs("\\nas-sp01\share\○○部\○○\○○\○○班用\★★★○○申請\", Worksheets("建築物(表面)5.3").Range("CE1").Text)
If saveFilePath = "" Then Exit Sub
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'＜新規にブックを追加します。＞
Sheets.Select
ActiveWindow.SelectedSheets.Copy
With ActiveWorkbook
.SaveAs Filename:=saveFilePath, FileFormat:=52
.Close
End With
ThisWorkbook.Activate
Sheets(1).Select Replace:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

テスト時は下記を考慮してください。
元ブックの保存でなく元ブックを基に新規作成して名前を付けて保存します
Window APIはバージョンなどの問題があるかも知れません。
API部分はほぼコピペです。時間が無く十分な検証はしていません。

No.10 回答者： Qchan1962 回答日時： 2022/01/12 17:18

＃３です

横から入るタイミングでないと思いますが、すみません。
GetSaveAsFilenameは取得なのでファイル名を指定することは出来ませんでした。また、ブックの作成も
Sheets.Select
ActiveWindow.SelectedSheets.Copy
With ActiveWorkbook
.SaveAs Filename:=saveFilePath, FileFormat:=52
.Close
End With
ThisWorkbook.Activate
Sheets(1).Select Replace:=True
で良かったですね。

代替えの案で多分ダメでしょうけれど、簡単なのは
元ファイルの保存をネットワークフォルダに保存して　
そこから操作すれば
Application.Dialogs(xlDialogSaveAs).Show Arg1:=ThisWorkbook.Path & "\" & Range("CF1").Value
で出来ると思います
後はAPIで作るとか、、
煮詰まっている所、失礼しました。

No.9 回答者： tatsumaru77 回答日時： 2022/01/12 16:23

黄色くなるのが①又は②だとすると、シート名が実在しない可能性があります。

①の場合、Sheet7　は存在しますか。
②の場合、建築物（表面5.3　は存在しますか。
建築物（表面5.3）が実際のシート名のような気がします。
全角のとじかっこ"）"が提示されたスクリプトにはありません。

No.8 回答者： tatsumaru77 回答日時： 2022/01/12 16:10

＞どちら新しいコード部分が黄色くエラーになってしまいます。

黄色くなるのは
①initName = folder & Worksheets("Sheet7").Range("CF1").Value
ですか
②initName = folder & Worksheets("建築物（表面5.3").Range("CF1").Value
ですか、
③他の行
ですか。①②③のどれでしょうか。

No.7 回答者： tatsumaru77 回答日時： 2022/01/12 16:02

>どうすればよいでしょうか？こちら側のPCの設定の問題でしょうか？

申し訳ありません。ネットワーク上の問題となると、こちらではわかりかねます。社内のネットワーク担当者に聞かれるのが、良いかと思います。

initName = folder & Range("CE1").Value
のかわりに
initName = folder & "ABCD"
として、ABCDが表示されれば、アクティブシートの問題になります。
アクティブシートの問題であれば、No5,No6が解決方法です。
なにも表示されなければ、folderの内容がおかしいということになります。
その場合、folderの内容をどのように修正すればよいかは、こちらではわかりません。社内のネットワーク担当者に聞けば解決するかと思います。

No.6 回答者： tatsumaru77 回答日時： 2022/01/12 15:11

ちなみに、そのCE1のシート名がSheet1であるなら

initName = folder & Range("CE1").Value
を
initName = folder & Worksheets("Sheet1").Range("CF1").Value
のようにすると、かならずSheet1のCE1セルを参照するので、シート名
を指定するようにした方が安全です。
そうでないと、今回のような現象が発生します。