在单元格的文件path中打开保存窗口，并从单元格填充文件名

我有一个工作簿，我用作模板来估计，当我完成填写模板时，有一个macros创build一个新的工作簿，并将模板工作簿的所有工作表复制到新的，然后删除所有公式和信息我不希望客户看到。

这是我的代码的一部分，创build新的工作簿，并将模板中的所有工作表复制到新的工作簿，然后清理它

Sub TestConvert() 'Disabling the following to speed up the vba code, must re-enable at end of code ActiveSheet.DisplayPageBreaks = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayAlerts = False 'adds file name and path to all sheets Dim WSfn As Worksheet For Each WSfn In ThisWorkbook.Sheets 'Adds formula to show file path WSfn.Range("A2") = "=LEFT(CELL(""filename"",RC),FIND(""["",CELL(""filename"",RC),1)-1)" 'Adds formula to show file name WSfn.Range("A3") = "=MID(CELL(""filename""),FIND(""["",CELL(""filename""))+1,(FIND(""]"",CELL(""filename""))-FIND(""["",CELL(""Filename""))-16))" WSfn.Calculate 'Calculate sheet WSfn.Range("A2") = WSfn.Range("A2") 'this will remove the formula from the cell making it text only WSfn.Range("A3") = WSfn.Range("A3") 'this will remove the formula from the cell making it text only Next '************************************************************************************************ 'copies all the sheets of the open workbook to a new one Dim thisWb As Workbook, wbTemp As Workbook Dim ws As Worksheet Set thisWb = ThisWorkbook Set wbTemp = Workbooks.Add 'creates new workbook dimmed as WbTemp On Error Resume Next 'if there is in error when deleting will not stop the macro from continuing... '.. deletes the extra sheets 2 sheets if on an older versions of excel For Each ws In wbTemp.Worksheets ws.Delete 'deletes all but one sheet in new workbook Next On Error GoTo -1 'clears the error handling and sets it to nothing which allows you to create another error trap. 'copys all the sheets from the original to the new workbook dimmed as wbTemp For Each ws In thisWb.Sheets ws.Copy After:=wbTemp.Sheets(wbTemp.Worksheets.Count) Next wbTemp.Sheets(1).Delete 'deletes the the first sheet in the list in the new workbook which is a black sheet from creating a new workbook 'put vba code to be ran in new book here 'makes all formulas in new workbook values only wbTemp.Sheets.Select 'selects all sheets in new workbook Cells.Select 'selects all cell Selection.Copy 'copies everything selected Selection.PasteSpecial Paste:=xlPasteValues 'pastes as values only in selected cells wbTemp.Application.CutCopyMode = False 'clears the clipbored 'removes all defind names from new workbook / submittal Dim xName As Name For Each xName In wbTemp.Names xName.Delete Next 'removes all dropdowns from new workbook / submittal Dim DD As Worksheet For Each DD In wbTemp.Worksheets Cells.Select DD.Cells.Validation.Delete Range("A1").Select Next 'removes all vba buttons from all sheets Dim i As Integer On Error Resume Next For i = 1 To 1000 wbTemp.Sheets(i).Buttons.Delete Next i 'All sheets scroll to top left and select "A1" Dim Sht As Worksheet '**************************** 'change A1 to suit your preference Const TopLeft As String = "A1" '**************************** 'loop thru all the sheets in the workbook For Each Sht In Worksheets 'scroll:=True takes cell to the top-left of window Application.Goto Sheet.Range(TopLeft), scroll:=True Next 'Hides the following from all sheets wbTemp.Sheets.Select 'selects all sheets in new workbook ActiveWindow.DisplayGridlines = False ActiveWindow.DisplayHeadings = False 'selects the first sheet in the list Sheets(1).Select ActiveSheet.DisplayPageBreaks = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayAlerts = True 'save vba code here 'works to only add the filename would like it to also open in file path from cell A2 Application.Dialogs(xlDialogSaveAs).Show Range("A3").Text & "- (Submittal) " & Format(Date, "mm-dd-yy") & "_" & Format(Time, "hhmm") & ".xlsx" End Sub 

即时通讯想要这样做，当保存窗口打开它打开在单元格A2的文件path，并填充单元格的文件名A3

如果有帮助，我也可以发送/张贴完整的Excel文件。

Answer 1

Application.GetSaveAsFilename方法是一个不错的select。 将返回值传递给variablestypesvar，以便testingCancel或Close。

 Dim sFN As Variant With Worksheets("Sheet6") sFN = .Range("A1") & Chr(92) & .Range("A2") & Format(Date, "_mm-dd-yy") '<~~ no extension yet End With With Application sFN = .GetSaveAsFilename(InitialFileName:=sFN, _ FileFilter:="Excel Workbook (*.xlsx), *.xlsx," & _ "Macro Workbook (*.xlsm), *.xlsm," & _ "Binary Workbook (*.xlsb), *.xlsb") End With Select Case sFN Case False 'user clicked Cancel or Close (×) Debug.Print sFN Case Else With ThisWorkbook Select Case Right(sFN, 5) Case ".xlsx" .SaveAs Filename:=sFN, FileFormat:=xlOpenXMLWorkbook Case ".xlsm" .SaveAs Filename:=sFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled Case ".xlsb" .SaveAs Filename:=sFN, FileFormat:=xlExcel12 Case Else 'there really shouldn't be a case else End Select End With End Select 

我已经为三个msot普通types的Excel工作簿添加了一个Select Case语句，用于Workbook.SaveAs方法 。

Answer 2

您可以使用对话框的.InitialFileName属性。

 Dim ws As Excel.Worksheet Set ws = ActiveWorkbook.Sheets("Sheet1") Dim oFileDialog As FileDialog Set oFileDialog = Application.FileDialog(msoFileDialogSaveAs) With oFileDialog .Title = "Save File" .ButtonName = "Ok" .InitialFileName = ws.Range("A2").Value & "\" & ws.Range("A3").Value .Show End With 

如果您需要取回保存的名称，您可以在.Show后使用.SelectedItems

 MsgBox (oFileDialog.SelectedItems(1)) 

注意：
您可能想要在执行此操作之前快速validationA2中的目录是否存在。 如果它不存在，它会把这个放到一些用户文件夹中。

编辑我不知道你为什么不保存，可能是你的代码中的Excel版本或其他variables。

既然你有path和名字，你真的需要saveas对话框吗？ 你可以做

 Workbooks.Add 'Then your code in your template that is modifying the active workbook 'Then save it without the dialog ActiveWorkbook.SaveAs ws.Range("A2").Value & "\" & ws.Range("A3").Value 'OR ActiveWorkbook.SaveAs Filename:= ws.Range("A2").Value & "\" & ws.Range("A3").Value