使用.filedialog將查詢結果導出到新的excel文件

Question

我有一個拆分數據庫，其中包含一個顯示查詢過濾結果的窗體。我只是想將結果導出到新的Excel應用程序/工作簿中。我只能找到導出到現有文件的示例，我想要一個空白文件，以便用戶可以將其保存在他們想要的位置。如何從filedialog提示符中獲取路徑和名稱並將其設置爲變量，以便我可以將它放在DoCmd.TransferSpreadsheet？結果我得到現在的問題是「FileDialog的（msoFileDialogSaveAs）」作爲文件名....

Private Sub btnToExcel_Click() 

    Dim fd As Office.FileDialog 

    Set fd = Application.FileDialog(msoFileDialogSaveAs) 

    With fd 

     .AllowMultiSelect = True   

     .Title = "Please select file to save" 

     If .Show = True Then 

     Else 

      MsgBox "You clicked Cancel." 

     End If 

    End With 

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Scale_Log", fd, True 

    End Sub 

Answer 1

將其他工件拼湊在一起。將項目從列表框複製到新的Excel工作簿。列表框顯示我的查詢結果。

私人小組btnExport_Click（）

Dim myExApp As Excel.Application 'variable for Excel App 

    Dim myExSheet As Excel.Worksheet 'variable for Excel Sheet 

    Dim i As Long      'variable for ColumnCount 

    Dim j As Long      'variable for ListCount 

    Set myExApp = New Excel.Application 



    myExApp.Visible = True    'Sets Excel visible 

    myExApp.Workbooks.Add    'Add a new Workbook 

    Set myExSheet = myExApp.Workbooks(1).Worksheets(1) 



    For i = 1 To ltbFiltered.ColumnCount 'Counter for ColumnCount 

     ltbFiltered.BoundColumn = ltbFiltered.BoundColumn + 1 'Setting counter for BoundColumn 

     For j = 1 To ltbFiltered.ListCount 'Counter for ListCount 

      myExSheet.Cells(j, i) = ltbFiltered.ItemData(j - 1)  'Insert ItemData into Excel Worksheet 

     Next j 'Iterating through ListCount 

    Next i 'Iterating through ColumnCount 

    ltbFiltered.BoundColumn = 1 'Setting BoundColumn to original 1 



    Set myExSheet = Nothing 'Release Worksheet 

    Set myExApp = Nothing 'Release Excel Application 



    End Sub 

Answer 2

這裏有一組I使用表導出到Excel的功能。 Export_Data會提示確定它是新文件還是現有文件，然後使用Get_File或Get_Folder瀏覽路徑。它使用了一些其他內容，這些內容不包括在內 - 包括函數調用中使用的要導出的東西表以及執行實際副本到工作簿的「轉儲」例程。如果這個例子回答你的問題，那很好 - 如果你需要更多的細節讓我知道。

Public Function Export_data(Optional table As String = "export test") 

    'On Error GoTo NextTab 

    'clear excel 
    MsgBox ("Save and close all excel workbooks") 
    n = close_excel() 
    Set wb_app = CreateObject("Excel.Application") 
    wb_app.DisplayAlerts = False 
    Set wb_obj = wb_app.Workbooks.Add 
    wb_obj.Activate 

    opt = InputBox("existing template (E) or new file (input file name)") 
    If opt = "E" Then 
     FileName = Get_File() 
     Set wb_obj = wb_app.Workbooks.Open(FileName) 
     Else: 
     Path = Get_Folder() 
     FileName = Path & "\" & opt & ".xlsx" 
     Set wb_obj = wb_app.Workbooks.Add 
     wb_obj.Sheets(1).Name = "Index" 
     End If 
    wb_obj.Activate 

    'Get list of Exports to process 
    Set Exports = CurrentDb().OpenRecordset("select * from [" & table & "] order by worksheet") 

    'Process the exports 
    Do While Not Exports.EOF 
     ws_name = Exports.Fields("Worksheet") 
     Source = Exports.Fields("Source_data") 
     Set source_data = CurrentDb().OpenRecordset(Source) 
     'Set qdf = CurrentDb().QueryDefs(Source) 
     'If qdf.Parameters.Count > 0 Then 
     ' For Each prm In qdf.Parameters 
     '  prm.Value = Eval(prm.Name) 
     '  Next prm 
     ' End If 
     'Set source_data = qdf.OpenRecordset(dbOpenDynaset) 

     x = dump(source_data, ws_name, wb_obj) 
     source_data.Close 

     Exports.MoveNext 
     Loop 

    'add index 
    x = Index(wb_obj) 

    'save & close 
    ftype = Mid(FileName, InStr(FileName, ".")) 
    FileName = Left(FileName, InStr(FileName, ".") - 1) 
    wb_obj.SaveAs FileName & " " & Format(Now(), "yyyy-mm-dd") & ftype 
    wb_obj.Close 

    'final cleanup 
    wb_app.DisplayAlerts = True 
    wb_app.Quit 
    Set source_data = Nothing 
    Set Exports = Nothing 
    Set list = Nothing 
    Set db = Nothing 
    Set wb_obj = Nothing 
    Set wb_app = Nothing 
    n = close_excel() 
    MsgBox ("Exports Completed") 

    End Function 

    Public Function Get_File(Optional ftype = "xls") 

    Dim fd As Object 
    Const msoFileDialogFolderPicker = 4 
    Const msoFileDialogFilePicker = 3 
    Const msoFileDialogViewDetails = 2 

    'Create a FileDialog object as a File Picker dialog box. 
    Set fd = Application.FileDialog(msoFileDialogFilePicker) 
    fd.AllowMultiSelect = False 
    fd.ButtonName = "Select" 
    fd.InitialView = msoFileDialogViewDetails 
    fd.Title = "Select File" 
    fd.InitialFileName = "MyDocuments\" 
    fd.Filters.Clear 
    fd.Filters.Add "Files", "*." & ftype & "*" 

    'Show the dialog box and get the file name 
    If fd.Show = -1 Then 
     Get_File = fd.SelectedItems(1) 
     Else 
     Get_File = "" 
     End If 

    End Function 

    Public Function Get_Folder() 

    'Create a FileDialog object as a Folder Picker dialog box. 
    Const msoFileDialogFolderPicker = 4 
    Const msoFileDialogFilePicker = 3 
    Const msoFileDialogViewDetails = 2 

    Set fd = Application.FileDialog(msoFileDialogFolderPicker) 
    fd.AllowMultiSelect = False 
    fd.ButtonName = "Select" 
    fd.InitialView = msoFileDialogViewDetails 
    fd.Title = "Select Folder" 
    fd.InitialFileName = "MyDocuments\" 
    fd.Filters.Clear 

    'Show the dialog box and get the file name 
    If fd.Show = -1 Then 
     Get_Folder = fd.SelectedItems(1) 
     Else 
     Get_Folder = "MyDocuments\" 
     End If 

    Set fd = Nothing 
    End Function