Boa tarde pessoal.
Criei um banco de dados para controle de recebimento e entrega de cartões. A inclusão dos dados é realizada através de um formulário no excel.
Esse formulário também tem a opção de consulta dos dados já existentes. a consulta devolve as informações no próprio formulário para visualização em tela.
O meu problema é que caso exista mais de um registro não será possível verificar todos eles no formulário. A minha saída então foi criar uma espécie de relatório. Ao clicar em consultar primeiro é chamada uma função que conta quantos registros a consulta retornará. Se for mais de um é criado um arquivo excel onde os registros seriam guardados. Entretanto a função Insert Into OpenRowSet está apresentando erro.
Disponibilizo abaixo os códigos. Se alguém puder me dar um luz eu agradeço.
Esse código é o contador. ele verifica no BD quantos registros são compatíveis com o critério de busca.
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
Se o valor retornado for maior que 1 (Contador>1) então é chamada uma função que cria o arquivo xls:
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
A função CriarArquivo, por sua vez, chama uma outra função que insere o cabeçalho:
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
Após todo esse processo é chamada a função para inserir os dados na planilha:
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
Todos os códigos são executados normalmente. O arquivo é criado e o cabeçalho inserido. Mas na hora de inserir os resultados da consulta é apresentado o erro abaixo:
O erro é apontado na penúltima linha da função relatório onde consta o "rs.Open sql,cn"