Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Pesquisa não funciona

Esclarecimentos e dúvidas sob o Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel publicado no site e blog http://www.tomasvasquez.com.br
edsonichara
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Qua Jul 08, 2015 9:18 am

Pesquisa não funciona

Mensagem por edsonichara »

Baixei a planilha de cadastro de Fornecedores e testei.
Quando fui baixar em um computador para mostra-la a um amigo a pesquisa estava em branco. Será uma configuração do Excel?
Já habilitei as macros em opções.
Poderiam me ajudar?


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Rafael Monteiro
Consultor
Consultor
Mensagens: 277
Registrado em: Seg Nov 28, 2011 8:27 am
Localização: Sorocaba - SP
Contato:

Re: Pesquisa não funciona

Mensagem por Rafael Monteiro »

Por favor coloque em anexo a planilha que você baixou.


edsonichara
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Qua Jul 08, 2015 9:18 am

Re: Pesquisa não funciona

Mensagem por edsonichara »

Segue código da pesquisa
'Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel
'Autor: Tomás Vásquez
'http://www.tomasvasquez.com.br
'http://tomas.vasquez.blog.uol.com.br
'março de 2008

Option Explicit

'constantes para auxiliar na verificação do código
Private Const Ascendente As Byte = 0
Private Const Descendente As Byte = 1

Private Sub btnFiltrar_Click()
Call PopulaListBox(txtNomeEmpresa.Text, txtNomeContato.Text, txtEndereco.Text, txtTelefone.Text, txtCidade.Text, txtRegiao.Text)
End Sub

Private Sub lstLista_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If lstLista.ListIndex > 0 Then
Dim indiceRegistro As Long
indiceRegistro = frmCadastro.ProcuraIndiceRegistroPodId(lstLista.List(lstLista.ListIndex, 0))
If indiceRegistro <> -1 Then
Call frmCadastro.CarregaRegistroPorIndice(indiceRegistro)
End If
Unload Me
Else
lblMensagens.Caption = "É preciso selecionar um item válido na lista"
End If
End Sub

Private Sub UserForm_Initialize()
'preenche o cboDirecao e seleciona o primeiro item
cboDirecao.Clear
cboDirecao.AddItem "Ascendente"
cboDirecao.AddItem "Descendente"
cboDirecao.ListIndex = 0

Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)
End Sub

Private Sub PopulaListBox(ByVal NomeEmpresa As String, _
ByVal NomeContato As String, _
ByVal Endereco As String, _
ByVal Telefone As String, _
ByVal Cidade As String, _
ByVal Regiao As String)

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 * FROM [Fornecedores$]"

'monta a cláusula WHERE
'NomeDaEmpresa
Call MontaClausulaWhere(txtNomeEmpresa.Name, "NomeDaEmpresa", sqlWhere)

'NomeDoContato
Call MontaClausulaWhere(txtNomeContato.Name, "NomeDoContato", sqlWhere)

'Endereço
Call MontaClausulaWhere(txtEndereco.Name, "Endereço", sqlWhere)

'Cidade
Call MontaClausulaWhere(txtCidade.Name, "Cidade", sqlWhere)

'Telefone
Call MontaClausulaWhere(txtTelefone.Name, "Telefone", sqlWhere)

'Região
Call MontaClausulaWhere(txtRegiao.Name, "Região", sqlWhere)

'faz a união da string SQL com a cláusula WHERE
If sqlWhere <> vbNullString Then
sql = sql & " WHERE " & sqlWhere
End If

'faz a união da string SQL com a cláusula ORDER BY
If cboOrdenarPor.ListIndex <> -1 Then
sqlOrderBy = " ORDER BY " & cboOrdenarPor.List(cboOrdenarPor.ListIndex, 0)
'define a direção
Select Case cboDirecao.ListIndex
Case Ascendente
sqlOrderBy = sqlOrderBy & " ASC"
Case Descendente
sqlOrderBy = sqlOrderBy & " DESC"
End Select
'une a query order ao sql
sql = sql & sqlOrderBy
End If

Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenDynamic, _
adLockBatchOptimistic
End With

'pega o número de registros para atribuí-lo ao listbox
lstLista.ColumnCount = rst.Fields.Count

'preenche o combobox com os nomes dos campos
'persiste o índice
Dim indiceTemp As Long
indiceTemp = cboOrdenarPor.ListIndex
cboOrdenarPor.Clear
For Each campo In rst.Fields
cboOrdenarPor.AddItem campo.Name
Next
'recupera o índice selecionado
cboOrdenarPor.ListIndex = indiceTemp

'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
lstLista.List = myArray
'adiciona a linha de cabeçalho da coluna
lstLista.AddItem , 0
'preenche o cabeçalho
For i = 0 To rst.Fields.Count - 1
lstLista.List(0, i) = rst.Fields(i).Name
Next i
'seleciona o primeiro item da lista
lstLista.ListIndex = 0
Else
lstLista.Clear
End If

'atualiza o label de mensagens
If lstLista.ListCount <= 0 Then
lblMensagens.Caption = lstLista.ListCount & " registros encontrados"
Else
lblMensagens.Caption = lstLista.ListCount - 1 & " registros encontrados"
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
sqlWhere = sqlWhere & " " & NomeCampo & " LIKE '%" & Trim(Me.Controls(NomeControle).Text) & "%'"
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

ErrFailed:
Debug.Print Err.Description
Debug.Assert False
Array2DTranspose = Empty
Exit Function
Resume
End Function


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Pesquisa não funciona

Mensagem por Reinaldo »

Não sei porque a resistência; da maioria dos usuários; em postar o modelo utilizado.
Pelo código/rotina/script não há erro;
porem para funcionar é preciso que os dados no formulário (nomes/campos/controles nomes de planilhas endereço de caminho etc...) estejam em linha com o código; as bibliotecas necessárias devem estar habilitadas/disponiveis em todas as maquinas em que forem executadas, etc.....


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


edsonichara
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Qua Jul 08, 2015 9:18 am

Re: Pesquisa não funciona

Mensagem por edsonichara »

RMarco me desculpe mas não entendo tanto de vba. Baixei a planilha do site http://www.tomasvasquez.com.br/download ... dastro.zip conhecido por todos.


Avatar do usuário
Rafael Monteiro
Consultor
Consultor
Mensagens: 277
Registrado em: Seg Nov 28, 2011 8:27 am
Localização: Sorocaba - SP
Contato:

Re: Pesquisa não funciona

Mensagem por Rafael Monteiro »

O modelo funcionou em um computador e no outro não?


edsonichara
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Qua Jul 08, 2015 9:18 am

Re: Pesquisa não funciona

Mensagem por edsonichara »

Isso mesmo funcionou no meu note e ni outro com office 2010 e windows 8 não


Avatar do usuário
Mikel Silveira Fraga
Jedi
Jedi
Mensagens: 1173
Registrado em: Sex Mai 27, 2011 3:27 pm
Localização: Governador Valadares - MG
Contato:

Re: Pesquisa não funciona

Mensagem por Mikel Silveira Fraga »

Boa tarde a todos.

Olha, não sou muito familiarizado com questões dos Drivers de conexão utilizados no Office, para utilizar arquivos mdf/accdb/xls/xlsx. Mais uma coisa eu observei no código.

Veja o comando abaixo:
.Provider = "Microsoft.JET.OLEDB.4.0"
Pelo que me recordo, eu li em um artigo que esse Driver/Provider é usado para as versões do Office 2007 e anteriores.

Apenas por curiosidade, tente alterar essa linha acima pela seguinte linha:

Código: Selecionar todos

.Provider = "Microsoft.ACE.OLEDB.12.0"
Como disse, não conheço muito, mas sei que esse drive foi desenvolvido para utilização em versões atuais do Office.

Acredito que vale a pena uma tentativa.


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Pesquisa não funciona

Mensagem por Reinaldo »

Bem notado Mikel, nessas situações deve ser "verificado" a versão do Excel/Access.
Se estiver em ambiente office de 32 bits experimente alterar a string de conexão, seria +/- assim:

Código: Selecionar todos

With conn
    If Val(Application.Version) < 12 Then
        .Provider = "Microsoft.JET.OLEDB.4.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
        .Open
    Else
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0;"
        .Open
    End If
End With
Porem se for executar em um ambiente office de 64 bits poderá ocorrer problemas, não sei qual a solução


edsonichara
Acabou de chegar
Acabou de chegar
Mensagens: 5
Registrado em: Qua Jul 08, 2015 9:18 am

Re: Pesquisa não funciona Resolvido

Mensagem por edsonichara »

Muito obrigado a todos o problema foi resolvido.
Valew
Abraços


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder