如何使用Excel VBA将新工作簿另存为原始工作簿目录？

Question

基本上，我想将一些工作表保存在与我派生的原始笔记本相同的系统位置中的单独的新工作簿中。

我知道默认路径是将新内容保存到当前笔记本的位置，但是也许由于我正在打开新工作簿，因此默认值将还原到用户的文档文件夹，这是他们现在保存的位置。

在过去的几天中，我“学习”了VBA，所以关于您注意到的其他事情的建议也很酷，但是saveas困扰着我。

Dim ws As Worksheet
Dim wb As Workbook
Dim dept_array As Variant
Dim dept As Variant

' Add or remove a department name spelled exactly as it is in the filter
dept_array = Array("HR", "IT", "Marketing", "Product Marketing", "Sales", "Channels", "Presales", "Direct", "Sales Ops", "R&D", "Support", "G&A")

Application.ScreenUpdating = False

For Each ws In Workbooks("Weekly Department Transaction Report.xlsm").Worksheets
    For Each dept In dept_array
        If Application.Proper(ws.Name) = Application.Proper(dept) _
        Then
             Set wb = Workbooks.Add
             ThisWorkbook.Sheets(dept).Copy Before:=wb.Sheets(1)
             wb.Saveas dept & "_" & Format(Now, "yyyymmdd") & ".xlsx"
             Workbooks("Weekly Department Transaction Report.xlsm").Sheets("Codes").Copy After:=Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Sheets(dept)
             Workbooks("Weekly Department Transaction Report.xlsm").Sheets("How").Copy Before:=Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Sheets(dept)
             Workbooks(dept & "_" & Format(Now, "yyyymmdd") & ".xlsx").Save
        End If
    Next dept
Next ws

Application.ScreenUpdating = True

End Sub

如果我没有遵循正确的stackoverflow格式，请告知我。 长期用户第一次问：)

Answer 1

在您的代码中编辑此行：

wb.SaveAs FileName:= ThisWorkbook.Path & "\" & dept & "_" & Format(Now, "yyyymmdd") & ".xlsx"