[[20150629184749]]　『サーバーに保存するマクロ』（たみ）　ページの最後に飛ぶ

『サーバーに保存するマクロ』（たみ）

マクロは初心者なんですが、現在作業日報をExcelで作っています。
作業日報は機械ごとのパソコンで保存してあり、1か月ごとのファイルを作って、毎日提出する形になります。
具体的にはKV-1-2015-06.xlsmという風に機械番号‐年号‐月のファイル名になっており、ファイル内に提出するボタンを作ってサーバーの各機械ごとのフォルダに保存するマクロを考えているのですが、その場合別名で保存と同じような方法でコードを考えたらいいのでしょうか？
サーバーに保存する際確認のためダイアログを表示して確認する方がいいかと思っています。
サーバーに保存するファイル名は開いているファイル名をそのまま使い、サーバー名\日報\KV-1\2015\KV-1-2015-06.xlsmという風に保存したいと考えています。
そのため、デフォルトの保存場所を開いているファイル名から指定したいのですが、その場合どうしたらいいでしょうか？
機械番号までのフォルダは必ずあると考えて、年号のフォルダが存在するかをまず確認して、もしなければ年号フォルダを作成することも必要かと考えています。
また毎日提出のため同じファイル名がすでに存在して上書き保存になることもあります。

GetSaveAsFileName 等を使うのまでは分かったのですが初心者のためこれらの動作を具体的にどうしたらいいのかよくまだ理解できないためアドバイス等頂けたら幸いです。
よろしくお願いします。

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

 > サーバーに保存するファイル名は、開いているファイル名をそのまま使い、
 > サーバー名\日報\KV-1\2015\KV-1-2015-06.xlsmという風に保存したいと考えています。

 「KV-1-2015-06.xlsm」をもとに、
 「サーバー名\日報\KV-1\2015\KV-1-2015-06.xlsm」というパス名を作ればよいのですね？

 > (2)機械番号までのフォルダは必ずあると考えて、
 >    年号のフォルダが存在するかをまず確認して、
 >    もしなければ年号フォルダを作成することも必要かと考えています。

 色々な書き方があると思いますが、一例です。

 Sub test()
     Dim sFileName   As String
     Dim s           As String
     Dim sYear       As String
     Dim sMachine    As String
     Dim sFolder     As String
     Dim sPathname   As String

   ' sFileName = ActiveWorkbook.Name
     sFileName = "KV-1-2015-06.xlsm"     '' テスト用
     s = Replace(sFileName, ".xlsm", "")
     sYear = Left(Right(s, 7), 4)
     sMachine = Left(s, Len(s) - 8)
     sFolder = "サーバー名\日報\" & sMachine & "\" & sYear
     sPathname = sFolder & "\" & sFileName
     Debug.Print sFolder
     Debug.Print sPathname
   ' "サーバー名\日報\KV-1\2015\KV-1-2015-06.xlsm" が
   ' イミディエイトウインドウに表示されるはずです。

   ' フォルダがなければ、フォルダを作成（テストしていません。確認してください。）
     If Dir(sFolder) = "" Then
         MkDir sFolder
     End If

   ''このあとに, MsgBox で sPathname を表示して確認させたり、
   ''sPathname を使って保存するコードを追加して下さい。
 End Sub

 # なお、質問は箇条書きにしたほうがよいと思います。

（γ） 2015/06/30(火) 05:48

コメントありがとうございます。
自分なりにコードを追加してみたのですが、勉強不足もありエラーが出てまだうまくいかない状況です。
コードは次のようにやってみました。

　　 Dim sFileName As String

     Dim s           As String
     Dim sYear       As String
     Dim sMachine    As String
     Dim sFolder     As String
     Dim sPathname   As String
　　 Dim sName       As String
' sFileName = ActiveWorkbook.Name
     sFileName = "KV-1-2015-06.xlsm"     '' テスト用
     s = Replace(sFileName, ".xlsm", "")
     sYear = Left(Right(s, 7), 4)
     sMachine = Left(s, Len(s) - 8)
     sFolder = "サーバー名\日報\" & sMachine & "\" & sYear
     sPathname = sFolder & "\" & sFileName
     Debug.Print sFolder
     Debug.Print sPathname
   ' "サーバー名\日報\KV-1\2015\KV-1-2015-06.xlsm" が
   ' イミディエイトウインドウに表示されるはずです。

   ' フォルダがなければ、フォルダを作成（テストしていません。確認してください。）
     If Dir(sFolder) = "" Then
         MkDir sFolder
     End If
　　　sName = Application.GetSaveAsFilename(sPathname)

     If sName <> False Then
     ActiveWorkbook.SaveAs sName

     End If
End Sub

まず年号のフォルダが有る場合sFolderが一致せずエラーになってしまいます。
else で繋げる必要があるまでは分かるのですが・・・

もう一つは保存のファイル名の部分が白紙のままでダイアログが出てしまう状況です。
アドバイスよろしくお願いします。

（たみ） 2015/07/01(水) 00:18

私のテスト用のコードではなく、実際に動かしたものを見せて下さい。
まさか、そのまま動かしているわけではないと思うので。
（γ） 2015/07/01(水) 06:39

 前提：
 このコードをブックにコピーペイストします。
 （対象とするブックは、その都度かわるでしょうから、
  これとは別のブックを作ってそこに登録したほうが良いでしょう。
  個人用マクロブック(Personal.xlsm)でも良いと思います。）

  対象となるブックをアクティブにした状態で、
  マクロtestを実行します。

 なお、対象となるブックのファイル名を元にして、
 保存先のフォルダ名を割り出す仕組みですから、
 対象となるブックのファイル名が正確にネーミングされていれば、
 GetSaveAsFilenameでファイル名を確認する必要はないはずです。

 Sub test()
     Dim sFileName   As String
     Dim s           As String
     Dim sYear       As String
     Dim sMachine    As String
     Dim sFolder     As String
     Dim sPathname   As String
     Dim fso         As Object

    '現在アクティブのBookのファイル名を取得
     sFileName = ActiveWorkbook.Name

     s = Replace(sFileName, ".xlsm", "")
     sYear = Left(Right(s, 7), 4)
     sMachine = Left(s, Len(s) - 8)

     sFolder = "\\で始まるサーバー名\日報\" & sMachine & "\" & sYear
                ' ↑ここは自分のサーバー名に修正すること

     sPathname = sFolder & "\" & sFileName

     '年号フォルダがなければ作成する（テストしていません）
     Set fso = CreateObject("Scripting.FileSystemObject")
     If fso.FolderExists(sFolder) = False Then
          MkDir sFolder
     End If

     ' ファイルの保存
     ActiveWorkbook.SaveAs sPathname, xlOpenXMLWorkbookMacroEnabled
  End Sub

（γ） 2015/07/01(水) 23:07

再度コード提示ありがとうございます。
GetSaveAsFilenameは場所の確認という意味で使いましたが、確かに必要もないかもですね。
上記コードで問題ないかと思ったのですが、上記コードのボタンを押して一回目は問題なくアップロードされて保存できるのですが、もう一度押すと「KV-1-2015-06.xlsm」にアクセスできませんと出てしまいます。
ファイルを開きなおすとまた一度目は問題ないですがやはり2度目はダメなようですね。
ファイルが既にある、無し関係なしに、1度目は問題なく2回目以降がダメな状況です。
何が原因なのでしょうか？

またすでに同じファイル名がある場合、上書きしますかというダイアログが出ますが、いいえとキャンセルを押した場合もエラーになってしまうのでその時の動作も記述しないといけないですかね？
（たみ） 2015/07/02(木) 18:31

 >私のテスト用のコードではなく、実際に動かしたものを見せて下さい。 
 に対する言及はないのでしょうか。
 何か、下請けにでも出しているつもりなのかな。
（γ） 2015/07/02(木) 20:44

 SaveCopyAsでご自分でトライしてください。
（γ） 2015/07/02(木) 20:49

実際試したコードはこのようになっています。

    Dim sFileName   As String
     Dim s           As String
     Dim sYear       As String
     Dim sMachine    As String
     Dim sFolder     As String
     Dim sPathname   As String
     Dim sName       As String
     Dim fso         As Object

     sFileName = ActiveWorkbook.Name
     s = Replace(sFileName, ".xlsm", "")
     sYear = Left(Right(s, 7), 4)
     sMachine = Left(s, Len(s) - 8)
     sFolder = "C:\Users\名前\OneDrive\Documents\日報\" & sMachine & "\" & sYear
     sPathname = sFolder & "\" & sFileName
      Set fso = CreateObject("Scripting.FileSystemObject")
     If fso.FolderExists(sFolder) = False Then
          MkDir sFolder
     End If

     ActiveWorkbook.SaveAs sPathname, xlOpenXMLWorkbookMacroEnabled

  End Sub

まだ会社のパソコンでは検証出来ていないので私用のパソコンになり、保存先が実際のサーバフォルダとはなっていません。
いいえ、キャンセルのエラー回避は　On Error Resume Next～で出来そうなので、SaveCopyAsでもやってみます。
（たみ） 2015/07/02(木) 21:23

返事がなかったので残念です。忙しかったのかな。

通じなかったようななので、もう少しはっきり申し上げておきます。

2015/07/01(水) 00:18 のあなたの投稿にはあきれました。

こちらのコードの理解に努めた形跡はまったくみられませんでした。
そのままだと動くわけがない。
フォルダ名だって、ファイル名だって、テスト用のものをそのまま使って、
動かない、と言われても困るよ。
もう少し、頑張って回答を受け止めて下さいな。
（γ） 2015/07/03(金) 22:28

コメント返信：

[ 一覧(最新更新順) ]

[[20150629184749]] 『サーバーに保存するマクロ』（たみ） ページの最後に飛ぶ

[[20150629184749]]　『サーバーに保存するマクロ』（たみ）　ページの最後に飛ぶ