.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ワークブックにコピーします。リストボックスに、クエリ結果が表示されます。

ます。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 

Answer 2

ですここで私は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