VBA 同じ場所に保存する

質問

部署ごとに分割し、ブックで保存するコードです。
保存場所がデスクトップになっています。
これを同じ場所に保存する方法をお知らせください。
よろしくお願いします。

Sub macro1()
Dim w As Worksheet
Dim n As Long
Dim r As Long
Dim s As String
Dim WSH As Variant
Dim myPath As String
Set w = ActiveSheet
n = Worksheets.Count

Application.ScreenUpdating = False

On Error GoTo errhandle
For r = 2 To w.Range("A65536").End(xlUp).Row
s = w.Cells(r, "A")
w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)
Next r
On Error GoTo 0

Set WSH = CreateObject("Wscript.Shell")
myPath = WSH.specialfolders("Desktop") & "\"

For r = Worksheets.Count To n + 1 Step -1
Worksheets(Worksheets.Count).Copy
ActiveSheet.Columns.AutoFit
ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name
ActiveWorkbook.Close False
Application.DisplayAlerts = False
Worksheets(Worksheets.Count).Delete
Application.DisplayAlerts = True
Next r
w.Select
Exit Sub

errhandle:
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = s
w.Rows(1).Copy Range("A1")
Resume
Application.ScreenUpdating = True
End Sub

回答No.4

kkkkkm · ベストアンサー

よく見たらActiveWorkbookは未保存ですからActiveWorkbook.Path は駄目でした
myPath = ThisWorkbook.Path & "\"

お礼

ありがとうございます。
うまくいけました。

回答No.3

kkkkkm

最後に\が必要でした
myPath = ActiveWorkbook.Path & "\"

回答No.2

kkkkkm

ActiveWorkbookの場所でしたら ActiveWorkbook.Pathが使えます

myPath = ActiveWorkbook.Path

回答No.1

eden3616

>Set WSH = CreateObject("Wscript.Shell")
>myPath = WSH.specialfolders("Desktop") & "\"

ここでmyPath変数にデスクトップのパスを格納し

>ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name

ここで、現在表示されているブックを上記ファイルパス+シート名で保存しています。
前者のファイルパスを格納している部分を目的の保存フォルダーのパスに変更すれば保存先を変えることができます。

>これを同じ場所に保存

同じ場所が何を意味しているか解りませんが以下のパターンで良ければ変更することで保存場所を変えることができます。

１）マクロを記述しているブックと同じ場所に保存する場合
Set WSH = CreateObject("Wscript.Shell")
myPath = WSH.specialfolders("Desktop") & "\"
　　　　　　　　　↓
myPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 1)

２）特定のフォルダパスに保存する場合（例：C:\TESTに保存する場合）
Set WSH = CreateObject("Wscript.Shell")
myPath = WSH.specialfolders("Desktop") & "\"
　　　　　　　　　↓
myPath ="C:\TEST"
※パスの最後に￥マークはつけないでください。

お礼

ありがとうございます。
一つ上のフォルダに保存しておりました。
myPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") - 1)
↓
myPath = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\") )
にすることでできました。
他に細かな保存方法を教えていただきありがとうございます。