VBAでのファイル保存の質問です

部門AでBookA、部門BでBookB、部門CでBookCのファイルを作成しています。
それぞれのBookの「H1」セルに「H28.10.31」の形式で日付データが入っています。

各々のデータを「部門」＋「H1セルの日付」のファイル名で、かつデスクトップに保存することはできるでしょうか？
部門ごとのデスクトップの位置は違うので、特殊フォルダでの指定が必要と思います。
「部門」＋「H1セルの日付」のファイル名での保存や、ファイル名を固定してデスクトップに保存はできるようなのですが、二つを同時にかなえる方法をご教示ください。

Windows10、Office2010の環境です。

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

• WindFaller様　回答ありがとうございます。
  
  試してみたところ
  「fName = Switch(mName = "A", "BookA", mName = "B", "BookB", mName = "C", "BookC")」の行で「Null　の使い方が不正です」「実行時エラー'94'」となります。

  No.1の回答に寄せられた補足コメントです。 補足日時：2016/10/31 08:18

• WindFaller様
  
  先頭行に「On Error Resume Next」を追加したところ、思い通りの結果が得られました。
  この対処でいいのでしょうか？

    補足日時：2016/10/31 08:40

• WindFaller様
  
  前回の補足、誤りでした。エラー回避のため付加されるべき「A」が付加されずにデスクトップに保存されました。

    補足日時：2016/10/31 08:53

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2016/10/31 09:27

こんにちは。

>fName = Switch(mName = "A", "BookA",
実は、この部分は、質問から連想した、私の単なる思いつきの範囲で、どうやって部門を決めるか分からないままに組み立てました。だから、エラーは当然と言えば当然なのですが……

>「Null　の使い方が不正です」「実行時エラー'94'」

エラーからみると、
　 mName = Application.UserName 'アプリのユーザー名の取得
　 '名前の置き換え
　 fName = Switch(mName = "A", "BookA", mName = "B", "BookB", mName = "C", "BookC")

ここのコードの部分は意味がないものになっているようです。

>前回の補足、誤りでした。エラー回避のため付加されるべき「A」が付加されずにデスクトップに保存されました

例えば、
今使っているユーザー名="(Officeにおいての)登録名", "BookA"
で、fName のところに、"BookA" を入れるという発想だったわけです。
別の登録したユーザーが使えば、別のブック名になって、"BookB" になるわけです。

この仕組が分かりますでしょうか。
このユーザー名は、

ファイル-オプション-基本設定-
Microsoft Office のユーザー設定

　ユーザー名(u) _______________

のところです。

Application.UserName　を使うと、その登録名が返ってくることになります。
それで分けようと考えたのです。

実は、もう一つ、ユーザー名があります。

ファイルのフルパスなどに登場するユーザー名は、
こちらです。

mName2 = Environ("USERNAME")

そのどちらかで分けたらよいとか考えました。

どのように部門を識別するか、私は、分からないままでしたので、そこが分かれば、問題は解決するのだと思っています。ただ、プライバシーの問題があるでしょうから、ご自身で書き換えていただくことになります。

No.1 回答者： WindFaller 回答日時： 2016/10/30 18:29

部門というのは、一体、どうやって取得するのでしょうか。

ユーザー名の違いかな？
後は、ご自身で加工してください。

Sub Test1()
Dim objShell As Object
Dim strDesktop As String
Dim mDate As Variant
Dim mName As String
Dim fName As String
　 mName = Application.UserName 'アプリのユーザー名の取得
　 '名前の置き換え
　 fName = Switch(mName = "A", "BookA", mName = "B", "BookB", mName = "C", "BookC")
　 If ActiveSheet.Range("H1").Value <> "" Then
　　 mDate = ActiveSheet.Range("H1").Text
　　 mDate = Replace(mDate, ".", "", , , 1)　'カンマ/ピリオドはファイル名として使えません
　 End If
　 fName = fName & mDate
　 Set objShell = CreateObject("WScript.Shell")
　 strDesktop = objShell.SpecialFolders("Desktop") & "\"
　 ActiveWorkbook.SaveAs strDesktop & fName, xlOpenXMLWorkbookMacroEnabled
End Sub

この回答へのお礼

こんにちは
たびたびの回答に深く感謝いたします。
fName="A" として、最終行を
ActiveWorkbook.SaveAs strDesktop & fName & ".xlsm", xlOpenXMLWorkbookMacroEnabled
とすることで目的通りの結果を売ることができました。

BookB、BookCにも同じような記述をすれば目的通りの結果が得られるようになります。
ありがとうございました。

お礼日時：2016/10/31 14:17