在单元格井的文件路径中打开保存窗口，也从单元格填充文件名

Question

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

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

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 的文件路径中打开并填充单元格 A3 的文件名

如果有帮助，我还可以发送/发布完整的 Excel 文件。

Answer 1

Application.GetSaveAsFilename 方法是一个不错的选择。将返回值传递给变体类型 var，以便您可以测试取消或关闭。

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

我已将 Workbook.SaveAs 方法的"选择大小写"语句语句添加到三种 msot 常见类型的 Excel 工作簿中。

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))

注意：
在执行此操作之前，您可能希望快速验证 A2 中的目录是否存在。 如果它不存在，它会将其扔到某些用户文件夹中。

编辑我不确定为什么你的不保存，可能是 excel 版本或代码中的其他变量。

既然您有路径和名称，您真的需要 save eas 对话框吗？ 你可以做

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