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的一组函数。 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

Answer 2

拼凑出其他可行的东西。将项目从列表框复制到新的Excel工作簿。列表框显示我的查询结果。

Private Sub 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

使用.filedialog将查询结果导出到新的excel文件

2 个答案: