同階層に別名で保存というVBAを作りたい

同階層に保存したいです。下記まで作成しました。

Dim ws As Worksheet
    Sheets("sheet1").Name = "test"
     ThisWorkbook = ThisWorkbook.Path
    Workbooks.Add
    ThisWorkbook.Sheets("test").Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
    Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.Name <> "test" Then ws.Delete
    Next ws
    Application.DisplayAlerts = True
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook & "Test.csv"
    ActiveWorkbook.Close
End Sub

＜やりたいこと＞
今は、実験中というフォルダー内に【text.xlsm】というエクセルがあり、
そこにたくさんシートがあります。
その中で【sheet1】だけを【test】というシート名に変更して、
【Test.csv】として、【実験中】という同階層のフォルダーに格納をしたいです。

＜現在の状況＞
しかし、この記述では、
【実験中】というフォルダーの一つ上の階層に
【実験中Test.csv】という名前で保存されてしまいます。

おそらくこの二行のせいだと思うのですが・・・。

３行目：ThisWorkbook = ThisWorkbook.Path
１２行目：ThisWorkbook & "Test.csv"

＜エラーの原因？＞
おそらく今は【ActiveWorkbook】の同階層に保存しようとしており、
【ActiveWorkbook】は、新規で作成しようとしているエクセルを指している（Test.csv）ので、
一つ上の階層に保存されてしまうのではないか・・・と予想しています。

そのため、
【ActiveWorkbook】ではない方のエクセル・・・もしくは【text.xlsm】という名前のエクセルと同階層に保存をする・・・という記述にしたいですが、そのやり方が分かりません。

もし分かりましたらご教授お願いいたします。

行動規範の内容に同意します

回答2件

ベストアンサー

フォルダ名とファイル名がくっついてしまっているので、ファイル名の前に¥¥を入れれば対象フォルダに出力されると思います。

VBA
1ThisWorkbook & "¥¥Test.csv"

投稿2019/08/30 04:05

shirokuma4690

総合スコア154

ExcelVBA
1Sub test()
2    Dim wb As Workbook
3    Dim sPath As String
4    
5    Application.ScreenUpdating = False
6    sPath = "C:\Users\ht\Desktop\Book1.xlsm"
7    Set wb = Workbooks.Open(sPath)
8    wb.Worksheets("Sheet3").Activate
9    Application.DisplayAlerts = False
10    wb.SaveAs Replace(sPath, wb.Name, "test.csv"), xlCSV
11    Application.DisplayAlerts = True
12    wb.Close False
13End Sub