How can I SaveAs a new workbook to original workbook directory with Excel VBA?

Question

Basically, I'd like to save some worksheets into separate new workbooks in the same system location as original notebook I am deriving from.

I recognize that the default path is to save something new is to the location of the current notebook, but perhaps since I am opening a new workbook the default reverts to the user's Document's folder, which is where they are saving right now.

I "learned" VBA over the last couple of days, so advice on other things you notice is cool too, but the saveas is what's bothering me.

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

Please let me know if I am not following the correct stackoverflow format. Longtime user first time asker :)

Answer 1

在您的代码中编辑此行：

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