在單元格的文件路徑中打開保存窗口，並在單元格中填充文件名

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

您可以使用對話框的.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版本或代碼中的其他變量。

由於您具有路徑和名稱，因此您真的需要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

Answer 2

為此， 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

我向三種常見的Excel工作簿類型添加了一個針對Workbook.SaveAs方法的Select Case語句 。