パソコンが変わってもマクロが実行できるようにしたい

質問

windowsXP Excel2000でマクロ作成しました。
私は　6）の　aaaa　のパソコンを使っています。
これをＵＳＢメモリで他のパソコンに複写し使おうとすると当然エラーがでます。
そのパソコンに
6)ChDir "C:\Documents and Settings\ｂｂｂｂ\デスクトップ\請求書フォルダ" '変更する。
とすればこのマクロが使えます。

パソコンが変わってもこのマクロが使えるようにしたいのですがどうすればよろしいでしょうか。
今はいちいち6）のaaaa、 bbbb部分を変更して使っています。

Sub ブック名に現在の日付を付加して保存()
1)Application.DisplayAlerts = False
2)Dim Filename As String
3)Application.DisplayAlerts = False
4)ChDrive ThisWorkbook.Path 'ブックのドライブに変更する。
5)ChDir ThisWorkbook.Path 'ブックのフォルダに変更する。
6)ChDir "C:\Documents and Settings\aaaa\デスクトップ\請求書フォルダ" '変更する。
7)Filename = Format(Date, "yyyymmdd")
8)On Error Resume Next
9)ActiveWorkbook.SaveAs Filename:="請求" & Filename & ".xls"
10)Err.Clear
11)Application.Quit
12)End Sub

回答No.2

noname#181803 · ベストアンサー

全体的に書き直しちゃったけど。(^_^;)
要は各PCのログインユーザーのデスクトップにある請求書フォルダの中に保存すればいいってことかな？
Windows環境ならEnviron関数を使ってみたらどう？

Option Explicit
Sub Sample()
Dim strFileName As String
Dim strSavePath As String
Dim intRe As Integer
Application.DisplayAlerts = False
strSavePath = Environ("HOMEPATH")
strSavePath = strSavePath & "\デスクトップ\請求書フォルダ"
If Dir(strSavePath, vbDirectory) = "" Then
MkDir (strSavePath)
End If
strFileName = strSavePath & "\請求" & Format(Date, "yyyymmdd") & ".xls"
If Dir(strFileName) <> "" Then
intRe = MsgBox(Prompt:="同名のファイルが存在します。上書きしますか？", Buttons:=vbYesNo)
Else
ThisWorkbook.SaveAs Filename:=strFileName
End If
If intRe = vbNo Then Exit Sub
If intRe = vbYes Then
ActiveWorkbook.SaveAs Filename:=strFileName
End If
Application.DisplayAlerts = True
End Sub

お礼

請求書フォルダの中に保存すればいいってことかな？
そうです。すごいです。一度試して使ってみます。ありがとうございました。

回答No.3

Wendy02

こんにちは。

こんな風に、Shell.Application　で、ローカル・デスクトップを取ったらどうでしょうか？それと、ChDir とか ChDrive とか、直接、保存する限りは、必要ないと思います。
なお、Namespaceの　0 　は、現ユーザのデスクトップ を指しているはずです。最初、MsgBox のコメントブロックを外して、試してみてください。なお、すでにファイルが存在しているものとして、請求フォルダがない場合のエラー処理はしてはおりません。

Sub SaveOtherPlace()
　Dim Filename As String
　Dim MyPath As String
　Dim w As Object
　Const BILLFOLDER As String = "請求書フォルダ"

　With CreateObject("Shell.Application")
　　MyPath = .Namespace(0).Self.Path & "\" & BILLFOLDER
　End With

　Application.DisplayAlerts = False
　Filename = Format(Date, "yyyymmdd")
　On Error Resume Next
　 'MsgBox MyPath & "\" & "請求" & Filename & ".xls" '検査用
　ActiveWorkbook.SaveAs Filename:= _
　　 MyPath & "\" &　"請求" & Filename & ".xls"
　If Err.Number > 0 Then MsgBox Err.Description
　Err.Clear
　On Error GoTo 0
　Application.DisplayAlerts = True

　For Each w In Application.Workbooks
　　w.Close False　'他はそのまま閉じられます。
　Next w
　Application.Quit　'環境によっては、Appは、終了しません。
End Sub

お礼

ありがとうございます。プロのような高級マクロにしていただき、申し訳ないです。早速試してみます。

回答No.1

hymatuyama00

aaaa を、
All Users
にすれば、いかがでしょうか？
"C:\Documents and Settings\All Users\デスクトップ\請求書フォルダ"

お礼

なるほど。でもちょっと使うには・・・。ありがとうございました。