Usuário com melhor resposta
Carregar um Array com um Recordset no VBA EXCEL

Pergunta
-
Senhores Experts,
Preciso carregar um array com o retorno de um recordset, mas não estou conseguindo de jeito nenhum, sempre recebo o retorno de que o número de campos do recordset é -1 e não consigo extrair nada dele. O Interessante é que se eu mando copiar pra uma planilha do excel funciona, ou seja, ele consegue retorno do banco normalmente.
O código que estou utilizando é o seguinte:
Private Sub cmb_buscarelacao_Click()
Dim objMyConn As ADODB.Connection
Dim objMyCmd As ADODB.Command
Dim rst As ADODB.Recordset
Dim Sstring As String
Dim ServerName As String
Dim VaData() As Variant
Dim row As Long, col As Long
Dim fd As Field
Dim oSql As String
'***************************************************************************************************
oSql = ""
oSql = oSql & " SELECT [Ope_ID] "
oSql = oSql & " ,convert(VARCHAR,[Data],103) AS DATA "
oSql = oSql & " ,Cliente.CNPJ_CIC "
oSql = oSql & " ,Cliente.Razao "
oSql = oSql & " ,[Qtde] "
oSql = oSql & " ,[Taxa] "
oSql = oSql & " ,[CodMoeda] "
oSql = oSql & " ,Vendas.[CodFilial] "
oSql = oSql & " ,Vendas.[CodUsuario] "
oSql = oSql & " ,[formaentr] "
oSql = oSql & " ,[fpagto] "
oSql = oSql & " ,[obs1] "
oSql = oSql & " ,[obs2] "
oSql = oSql & " ,[obs3] "
oSql = oSql & " ,Cliente.[FisJur] "
oSql = oSql & " FROM [th1014208_db].[dbo].[Vendas] left join Cliente on Vendas.CodCliente=Cliente.CodCliente "
oSql = oSql & " where Data between '" & Format(dtpk_buscade, "YYYY-MM-DD") & "' and '" & Format(dtpk_buscaate, "YYYY-MM-DD") & "'"
oSql = oSql & " and Vendas.CodFilial='056' "
oSql = oSql & " and CodMoeda like 'SC%' "
'***************************************************************************************************
Set objMyConn = New ADODB.Connection
Set objMyCmd = New ADODB.Command
Set rst = New ADODB.Recordset
Sstring = "Provider=SQLOLEDB; Data Source=XXXXX;INITIAL CATALOG=XXXXX;User ID=XXXXXX;Password=XXXXXX;Trusted_Connection=sspi"
'Open Connection'
objMyConn.ConnectionString = Sstring
objMyConn.Open
'Set and Excecute SQL Command'
Set objMyCmd.ActiveConnection = objMyConn
objMyCmd.CommandText = oSql
objMyCmd.CommandType = adCmdText
objMyCmd.Execute
'Open Recordset'
Set rst.ActiveConnection = objMyConn
rst.Open objMyCmd
'Sheets(3).Cells(2, 1).CopyFromRecordset rst
rst.MoveLast
ReDim SomeArray(rst.RecordCount - 1, rst.Fields.Count - 1)
'Neste ponto a propriedade RecordCount do objeto rst sempre me retorna -1
With rst
i = .Fields.Count
j = .RecordCount
End With
rst.MoveFirst
'Transfer the recordset to the array of variant-type.
VaData = rst.GetRows()
'Testing purpose only
'Debug.Print UBound(rst) + 1 'Due to 0-based array
'Debug.Print LBound(rst) + 1 'Due to 0-based array
'
'Debug.Print "Number of fields = " & i
'Debug.Print "Number of records = " & j
'Disconnect and empty memory.
rst.Close
Set rst = Nothing
cnn.Close
Set cnt = Nothing
oSql = ""
End Sub
- Movido Marcelo Fernandes da SilvaMVP sexta-feira, 20 de abril de 2012 20:43 forum errado (De:SQL Server - Desenvolvimento Geral)
Respostas
-
Uma vez que o método CopyFromRecordset funciona, a informação está no RecordSet.
Veja o exemplo a seguir: https://skydrive.live.com/redir.aspx?cid=fb206a2d510e0661&resid=FB206A2D510E0661!343&parid=FB206A2D510E0661!275&authkey=!AMyB3uN4gTw-cY4
Código:
Sub RecordSet2Variant()
Dim v As Variant
Dim l1 As Long
Dim l2 As Long
v = SQL("SELECT Nome, Idade FROM [Plan1$]")
For l1 = LBound(v, 1) To UBound(v, 1)
For l2 = LBound(v, 2) To UBound(v, 2)
Debug.Print v(l1, l2)
Next l2
Next l1
End Sub
Function SQL(sSQL As String) As Variant
'Necessita de referência à biblioteca Microsoft ActiveX Objects 2.0 ou superior
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
Select Case Val(Application.Version)
Case 8, 9, 10, 11
cn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0"
Case 12, 14
cn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0"
End Select
cn.Open
Set rs = cn.Execute(sSQL)
SQL = rs.GetRows
rs.Close
cn.Close
End Function
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
- Sugerido como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 21:43
- Marcado como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 21:43
Todas as Respostas
-
-
-
Benzadeus, infelizmente não funcionou.
Uma vez eu vi um código que funciou, mas não me lembro direito o que foi feito diferente, acredito que tenha ligação com o método de retorno da query do servidor, se não me engano o cara usava algo diferente do recordset.
-
Uma vez que o método CopyFromRecordset funciona, a informação está no RecordSet.
Veja o exemplo a seguir: https://skydrive.live.com/redir.aspx?cid=fb206a2d510e0661&resid=FB206A2D510E0661!343&parid=FB206A2D510E0661!275&authkey=!AMyB3uN4gTw-cY4
Código:
Sub RecordSet2Variant()
Dim v As Variant
Dim l1 As Long
Dim l2 As Long
v = SQL("SELECT Nome, Idade FROM [Plan1$]")
For l1 = LBound(v, 1) To UBound(v, 1)
For l2 = LBound(v, 2) To UBound(v, 2)
Debug.Print v(l1, l2)
Next l2
Next l1
End Sub
Function SQL(sSQL As String) As Variant
'Necessita de referência à biblioteca Microsoft ActiveX Objects 2.0 ou superior
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
Select Case Val(Application.Version)
Case 8, 9, 10, 11
cn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0"
Case 12, 14
cn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0"
End Select
cn.Open
Set rs = cn.Execute(sSQL)
SQL = rs.GetRows
rs.Close
cn.Close
End Function
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
- Sugerido como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 21:43
- Marcado como Resposta Felipe Costa GualbertoMVP, Moderator sábado, 7 de junho de 2014 21:43