使用.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