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

Pesquisa em VBA

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
heltonadm
Colaborador
Colaborador
Mensagens: 13
Registrado em: Seg Mar 16, 2020 7:26 pm

Pesquisa em VBA

Mensagem por heltonadm »

Pessoal boa noite,

Montei um formulario de cadastro de cliente e agora estou elaborando uma pesquisa para esse cadastro, quando eu clico no botao pesquisar nao da nem um erro mas tb não aparece nenhum informação da consulta que eu estou fazendo,

Segue abaixo a linguagem:

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(txtNomeFantasia.Text, txtClienteAtivo.Text, txtEndereço.Text, txtCelular.Text, txtCidade.Text, txtPaís.Text)
End Sub


Private Sub frmFiltrar_Click()

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 txtClienteAtivo_Change()

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 NomeFantasia As String, _
ByVal ClienteAtivo As String, _
ByVal Endereço As String, _
ByVal Celular As String, _
ByVal Cidade As String, _
ByVal País 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 [Cadastro$]"

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

'NomeDoContato
Call MontaClausulaWhere(txtClienteAtivo.Name, "ClienteAtivo", sqlWhere)

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

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

'Telefone
Call MontaClausulaWhere(txtCelular.Name, "Celular", sqlWhere)

'Região
Call MontaClausulaWhere(txtPaís.Name, "País", 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

Aonde esta o erro?


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
webmaster
Administrador
Mensagens: 3114
Registrado em: Sex Jul 24, 2009 2:44 pm
Contato:

Re: Pesquisa em VBA

Mensagem por webmaster »

1 - Qual o erro?
2 - Dá para anexar o arquivo?


heltonadm
Colaborador
Colaborador
Mensagens: 13
Registrado em: Seg Mar 16, 2020 7:26 pm

Re: Pesquisa em VBA

Mensagem por heltonadm »

Não esta aparecendo nenhum erro, porem tb não esta gerando a informação

Não estou conseguindo anexar, sabe porque.

Deixa eu tentar explicar, o cadastro de cliente esta funcionando normal. dai no cadastro tem um botão chamado pesquisar e dai abre uma outra tela, so que quando vou pesquisar a informação ele nao aparece nada.

Se tiver outro lugar para anexar o arquivo me avise


heltonadm
Colaborador
Colaborador
Mensagens: 13
Registrado em: Seg Mar 16, 2020 7:26 pm

Re: Pesquisa em VBA

Mensagem por heltonadm »

Tomás, eu estou usando o seu modelo de VBA de pesquisa, sabe porque não está funcionando?


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.


Tov Elen Shau
Manda bem
Manda bem
Mensagens: 173
Registrado em: Qua Mai 17, 2017 2:27 pm

Re: Pesquisa em VBA

Mensagem por Tov Elen Shau »

Bom dia

Para anexar é preciso compactar o arquivo.

Atenciosamente

Tov Elen Shau


heltonadm
Colaborador
Colaborador
Mensagens: 13
Registrado em: Seg Mar 16, 2020 7:26 pm

Re: Pesquisa em VBA

Mensagem por heltonadm »

Segue o arquivo
Anexos
Cadastro_16_03.zip
(110.94 KiB) Baixado 224 vezes


Avatar do usuário
webmaster
Administrador
Mensagens: 3114
Registrado em: Sex Jul 24, 2009 2:44 pm
Contato:

Re: Pesquisa em VBA

Mensagem por webmaster »

heltonadm,

O primeiro erro é:

Isso:

Código: Selecionar todos

    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
Deveria ser isso:

Código: Selecionar todos

    Set conn = New ADODB.Connection
    With conn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
        .Open
    End With
A partir deste ponto, é preciso resolver os outros erros que aparecem, relacionados ao SQL.


heltonadm
Colaborador
Colaborador
Mensagens: 13
Registrado em: Seg Mar 16, 2020 7:26 pm

Re: Pesquisa em VBA

Mensagem por heltonadm »

obrigado, Agora está aparecendo as informações, mas nada de filtro esta aparecendo automatico, ja fiz toda a revisão da linguagem e nao consegui achar o problema.

Poderia me ajudar?

obrigado


Avatar do usuário
webmaster
Administrador
Mensagens: 3114
Registrado em: Sex Jul 24, 2009 2:44 pm
Contato:

Re: Pesquisa em VBA

Mensagem por webmaster »



heltonadm
Colaborador
Colaborador
Mensagens: 13
Registrado em: Seg Mar 16, 2020 7:26 pm

Re: Pesquisa em VBA

Mensagem por heltonadm »

Tentei usar o depurar mesmo assim não consegui resolver, alguem consegue me ajudar?
obrigado


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