Vídeo recomendado
https://youtu.be/diWPPPhW-9E
https://youtu.be/diWPPPhW-9E
Erro para conectar a outra tabela
Erro para conectar a outra tabela
Olá, eu usei o seu modelo de cadastro para popular um listbox, e nem mudei o código(
Private Sub PopulaListResumo()
'On Error GoTo TrataErro
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
Dim i As Integer
Dim campo As Field
Dim myArray() As Variant
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
.Open
End With
)
Mas quando ele chega no Open. ele dá um erro "ERRO EM TEMPO DE EXECUÇÃO '-2147467259 (80004005)':
A tabela externa não está no formato experado.
O que eu faço?
Obrigado
Private Sub PopulaListResumo()
'On Error GoTo TrataErro
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
Dim i As Integer
Dim campo As Field
Dim myArray() As Variant
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
.Open
End With
)
Mas quando ele chega no Open. ele dá um erro "ERRO EM TEMPO DE EXECUÇÃO '-2147467259 (80004005)':
A tabela externa não está no formato experado.
O que eu faço?
Obrigado
Re: Erro para conectar a outra tabela
Eu tô com uma outra dúvida, eu salvei o arquivo como xls (versão 97-2003) e funcionou.
Mas por algum motivo quando eu tento popular o listbox (deveria ter duas colunas) ele só preenche com uma coluna.
O Array transposed tem duas colunas e 4 linhas na condição simulada, mas o list box exibe apenas a primeira coluna, alguma idéia?
O código é basicamente o que vc colocou no ModeloCadastro.xls:
Private Sub PopulaListResumo()
'On Error GoTo TrataErro
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
Dim i As Integer
Dim campo As Field
Dim myArray() As Variant
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT DAY(VENCIMENTO_CORRIGIDO) AS DIA, SUM([VALOR_(R$)]) AS VALOR FROM [BD$]" '
'monta a cláusula WHERE
'NomeDaEmpresa
Call MontaClausulaWhere(ComboAno.Name, "year(VENCIMENTO_CORRIGIDO)", sqlWhere)
'NomeDoContato
Call MontaClausulaWhere(ComboMes.Name, "month(VENCIMENTO_CORRIGIDO)", sqlWhere)
'faz a união da string SQL com a cláusula WHERE
If sqlWhere <> vbNullString Then
sql = sql & " WHERE " & sqlWhere
End If
sqlOrderBy = " GROUP BY VENCIMENTO_CORRIGIDO ORDER BY VENCIMENTO_CORRIGIDO" '
sql = sql & sqlOrderBy
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenDynamic, _
adLockBatchOptimistic
End With
'coloca as linhas do RecordSet num Array, se houver linhas neste
If Not rst.EOF And Not rst.BOF Then
myArray = rst.GetRows
'troca linhas por colunas no Array
myArray = Array2DTranspose(myArray)
'atribui o Array ao listbox
ListResumo.List = myArray
'adiciona a linha de cabeçalho da coluna
ListResumo.AddItem , 0
'preenche o cabeçalho
For i = 0 To rst.Fields.Count - 1
ListResumo.List(0, i) = rst.Fields(i).Name
Next i
'seleciona o primeiro item da lista
ListResumo.ListIndex = 0
Else
ListResumo.Clear
End If
' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
conn.Close
TrataSaida:
Exit Sub
TrataErro:
Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End Sub
Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
'NomeDoContato
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " AND"
End If
If NomeControle = "ComboMes" Then
sqlWhere = sqlWhere & " " & NomeCampo & " LIKE " & Trim(Me.Controls(NomeControle).ListIndex) + 1
Else
sqlWhere = sqlWhere & " " & NomeCampo & " LIKE '%" & Trim(Me.Controls(NomeControle).Value) & "%'"
End If
End If
End Sub
'Faz a transpasição de um array, transformando linhas em colunas
Private Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant
If IsArray(avValues) Then
'On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)
ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If
Array2DTranspose = avTransposed
Exit Function
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume
End Function
Mas por algum motivo quando eu tento popular o listbox (deveria ter duas colunas) ele só preenche com uma coluna.
O Array transposed tem duas colunas e 4 linhas na condição simulada, mas o list box exibe apenas a primeira coluna, alguma idéia?
O código é basicamente o que vc colocou no ModeloCadastro.xls:
Private Sub PopulaListResumo()
'On Error GoTo TrataErro
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Dim sqlWhere As String
Dim sqlOrderBy As String
Dim i As Integer
Dim campo As Field
Dim myArray() As Variant
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT DAY(VENCIMENTO_CORRIGIDO) AS DIA, SUM([VALOR_(R$)]) AS VALOR FROM [BD$]" '
'monta a cláusula WHERE
'NomeDaEmpresa
Call MontaClausulaWhere(ComboAno.Name, "year(VENCIMENTO_CORRIGIDO)", sqlWhere)
'NomeDoContato
Call MontaClausulaWhere(ComboMes.Name, "month(VENCIMENTO_CORRIGIDO)", sqlWhere)
'faz a união da string SQL com a cláusula WHERE
If sqlWhere <> vbNullString Then
sql = sql & " WHERE " & sqlWhere
End If
sqlOrderBy = " GROUP BY VENCIMENTO_CORRIGIDO ORDER BY VENCIMENTO_CORRIGIDO" '
sql = sql & sqlOrderBy
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenDynamic, _
adLockBatchOptimistic
End With
'coloca as linhas do RecordSet num Array, se houver linhas neste
If Not rst.EOF And Not rst.BOF Then
myArray = rst.GetRows
'troca linhas por colunas no Array
myArray = Array2DTranspose(myArray)
'atribui o Array ao listbox
ListResumo.List = myArray
'adiciona a linha de cabeçalho da coluna
ListResumo.AddItem , 0
'preenche o cabeçalho
For i = 0 To rst.Fields.Count - 1
ListResumo.List(0, i) = rst.Fields(i).Name
Next i
'seleciona o primeiro item da lista
ListResumo.ListIndex = 0
Else
ListResumo.Clear
End If
' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
conn.Close
TrataSaida:
Exit Sub
TrataErro:
Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End Sub
Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
'NomeDoContato
If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " AND"
End If
If NomeControle = "ComboMes" Then
sqlWhere = sqlWhere & " " & NomeCampo & " LIKE " & Trim(Me.Controls(NomeControle).ListIndex) + 1
Else
sqlWhere = sqlWhere & " " & NomeCampo & " LIKE '%" & Trim(Me.Controls(NomeControle).Value) & "%'"
End If
End If
End Sub
'Faz a transpasição de um array, transformando linhas em colunas
Private Function Array2DTranspose(avValues As Variant) As Variant
Dim lThisCol As Long, lThisRow As Long
Dim lUb2 As Long, lLb2 As Long
Dim lUb1 As Long, lLb1 As Long
Dim avTransposed As Variant
If IsArray(avValues) Then
'On Error GoTo ErrFailed
lUb2 = UBound(avValues, 2)
lLb2 = LBound(avValues, 2)
lUb1 = UBound(avValues, 1)
lLb1 = LBound(avValues, 1)
ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
For lThisCol = lLb1 To lUb1
For lThisRow = lLb2 To lUb2
avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Next
Next
End If
Array2DTranspose = avTransposed
Exit Function
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume
End Function