Export SQL query data to Excel

1

Good afternoon guys.

I created a database to control receipt and delivery of cards. The inclusion of the data is done through a form in excel.

This form also has the option to query existing data. the query returns the information in the form itself for on-screen viewing.

My problem is that if there is more than one record you will not be able to check all of them on the form. My departure then was to create a kind of report. Clicking on Query First is called a function that counts how many records the query will return. If more than one is created an excel file where the records would be saved. However, the Insert Into OpenRowSet function is experiencing an error.

Available below the codes. If anyone can give me a light, I appreciate it.

This code is the counter. it checks the BD how many records are compatible with the search criteria.

    Public Function Contador()

        Dim TOTAL As Variant

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

        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 = "SELECT COUNT (*) FROM controle WHERE BP = '" & controlectform.nmbpbox.Value & "';"

        rs.Open sql, cn

        If Not rs.EOF Then
            Do While Not rs.EOF
                TOTAL = rs(0)
                rs.MoveNext
            Loop
        End If

        cn.Close

        Contador = TOTAL
End Function

If the value returned is greater than 1 (Counter > 1) then a function that creates the xls file is called:

Public Function CriaArquivo()

    Dim NovoArquivoXLS      As Workbook
    Dim sht                 As Worksheet
    Dim mPathSave           As String
    Dim PlanName            As String


    mPathSave = ThisWorkbook.Path

    PlanName = "SQLQueryControleCartoes"

    'Cria um novo arquivo excel
    Set NovoArquivoXLS = Application.Workbooks.Add

    'Salva o arquivo
    NovoArquivoXLS.SaveAs mPathSave & "\" & PlanName & ".xls"

    Call Cabecalho

End Function

The CreateArchive function, in turn, calls another function that inserts the header:

Public Function Cabecalho()

    Dim vArray As Variant 'variável insere dados vArray
    Dim vContador As Integer

    ' variavel vArrays variant com array de dados
    vArray = Array("", "ID", "TP_BENEFICIO", "BP", "CPF", "NOME", "DTADM", "FILIAL", "SOLICPOR", "DTSOLIC", _
    "DTRECEBE", "DTENVIOBS", "ENVIADORETIRADO", "NMMINUTA", "NRCARTAO")

    'Inserindo o cabeçalho na folha de planilha

    With Worksheets("Planilha1")
    For vContador = 1 To UBound(vArray)
    .Cells(1, vContador).Value = vArray(vContador)
    Next vContador
    End With

End Function

After all this process is called the function to insert the data into the worksheet:

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.Jet.OLEDB.4.0', 'Excel 8.0;Database= " & ThisWorkbook.Path & "\SQLQueryControleCartoes.xls', 'SELECT * FROM controle WHERE BP = '" & controlectform.nmbpbox.Value & "')"

    rs.Open sql, cn

End Function 

All codes are executed normally. The file is created and the header is inserted. But at the time of entering the results of the query the error below is displayed:

Theerrorispointedoutinthepenultimaterowofthereportfunctionwherethe"rs.Open sql, cn"

    
asked by anonymous 30.03.2017 / 17:29

1 answer

1

I solved the problem.

I leave the code below, should anyone else need it:

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 = ThisWorkbook.Path & "\CustomReports  " & Format(Date, "dd-mm-yyyy") & Format(Time, "  hh.mm.ss") & ".xls"
    name_of_sheet = "Planilha1"
    sql = "SELECT * INTO [Excel 12.0;Database=" & path_To_XLSX & "]." & name_of_sheet & " FROM controle WHERE BP = '" & controlectform.nmbpbox.Value & "';"

    rs.Open sql, cn

End Function

With this code I no longer needed the function that creates the file.

    
06.04.2017 / 20:54