如何将SQL语句结果导出到Excel文件

Question

我在Excel VBA中有一个Access DataBase和一个表单。我输入到数据库的所有数据都是通过VBA表格输入的。

该数据库包含我们今年在公司中收到的所有优惠卡。但是同一个员工可以要求两张或更多的卡片，所以我们将在他的数据库上有多条记录。

我需要的是当记录数大于1时，SQL语句结果应该出现在Excel报告中。

我使用SELECT (*) COUNT语句来知道何时有多个记录与搜索条件兼容。但是我不能让结果出现在Excel文件中。

这里是我的代码：

Public Function Relatorio() 
    Dim sql As String 
    Dim cn As ADODB.Connection 
    Dim rs As ADODB.Recordset 
    Dim rel As String 

    Set cn = New ADODB.Connection 
    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & enderecoDB & ";Jet OLEDB:Database" 
    cn.Open 
    Set rs = New ADODB.Recordset 
    sql = "INSERT INTO OPENROWSET('Microsoft.ACE.OLEDB.12.0', 'Excel 12.0;Database=" & enderecoDB & ";', 'SELECT * FROM [Planilha1$]') SELECT * FROM controle WHERE BP = " & controlectform.nmbpbox.Value & ";" 
    rs.Open sql, cn 
End Function 

当我运行这段代码是给了我一个消息，说是这样的：

无法找到OPENROWSET表出口

我无法安装新程序，所以我只需要使用Excel VBA和Access DB来完成此操作。

我该如何做这项工作？

Answer 1

我不相信Access支持OPENROWSET，你在那里工作的动态表。我有很多是这样做虽然老项目，所以这里是我的方法

Public Function Relatorio() 

    Dim sql As String 
    Dim cn As ADODB.Connection 
    Dim rs As ADODB.Recordset 
    Dim rel As String 


    Set cn = New ADODB.Connection 

    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & enderecoDB & ";Jet OLEDB:Database" 

    cn.Open 

    Set rs = New ADODB.Recordset 

    dim path_To_XLSX 
    dim name_of_sheet 
    path_To_XLSX = "c:\temp\output.xlsx" 
    name_of_sheet = "Planilha1" 
    sql = sql = "SELECT * INTO [Excel 12.0;Database=" & path_To_XLSX & "]." & name_of_sheet & " FROM controle WHERE BP = '" & controlectform.nmbpbox.Value & "';" 

    rs.Open sql, cn 

    'If this application is in an unsecure environment, use the following code instead! This is to prevent a SQL injection, security concern here. 
    'As it is an Access Database, this is likely overkill for this project 
    'Create Command Object. 
    Set Cmd1 = New ADODB.Command 
    Cmd1.ActiveConnection = cn 
    cmd1.CommandText = "SELECT * FROM controle INTO [Excel 12.0;Database=" & path_To_XLSX & "]." & name_of_sheet & " WHERE BP = ?" 
    ' Create Parameter Object. 
    Set Param1 = Cmd1.CreateParameter(, adInteger, adParamInput, 5) 'use adVarchar for strings(versus adInteger), https://www.w3schools.com/asp/met_comm_createparameter.asp 
    Param1.Value = controlectform.nmbpbox.Value 
    Cmd1.Parameters.Append Param1 
    Set Param1 = Nothing 
    Set Rs = Cmd1.Execute() 

End Function 

Answer 2

我很多年前就有这个挑战，我不记得，但这个环节鸣钟。检查它是否有帮助。

https://stackoverflow.com/a/28889774/382588

尝试{connw.Open（）; OleDbCommand命令; command = new OleDbCommand（“Update Deliveries”+“SET Deliveries.EmployeeID =？，Deliveries.FIN =？，Deliveries.TodaysOrders =？，connw）; command.Parameters.Add（new OleDbParameter（”@ EMPID“，Convert.ToDecimal （empsplitIt [1]）））; command.Parameters.Add（new OleDbParameter（“@ FIN”，truckSplit [1] .ToString（）））; command.Parameters.Add（new OleDbParameter（“@ TodaysOrder”，“R “））; catchReturnedRows = command.ExecuteNonQuery（）; //提交connw.Close（）;} catch（OleDbException异常）{MessageBox.Show（exception.Message，”OleDb Exception“）;}

Answer 3

您可以使用这将打印出实际的SQL

Private Sub Command2_Click() 

Dim db As Database 
Dim qr As QueryDef 

Set db = CurrentDb 

For Each qr In db.QueryDefs 
    TextOut (qr.Name) 
    TextOut (qr.SQL) 
    TextOut (String(100, "-")) 
Next 

End Sub 

Public Sub TextOut(OutputString As String) 

    Dim fh As Long 

    fh = FreeFile 
    Open "C:\Users\rs17746\Desktop\Text_Files\sample.txt" For Append As fh 
    Print #fh, OutputString 
    Close fh 

End Sub 

这是另外一个版本，它将导出每个查询的结果，一个单独的文本文件。

Private Sub Command0_Click() 


Dim qdf As QueryDef 
Dim strFileName As String 
For Each qdf In CurrentDb.QueryDefs 
If Left(qdf.Name, 1) <> "~" Then 

'you need to figure out TransferText command. Maybe 
'you won't be lazy and expect people to read it to 
'you and tutor you on how it works. 
strFileName = qdf.Name 

'Docmd.TransferText .... 
DoCmd.TransferText transferType:=acExportDelim, TableName:=strFileName, FileName:="C:\test\" & strFileName & ".txt", hasfieldnames:=True 

End If 
Next qdf 
MsgBox "Done" 


End Sub