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

Formulário de Pesquisa

Dúvidas gerais sobre Excel
mariogus
Colaborador
Colaborador
Mensagens: 11
Registrado em: Seg Out 19, 2009 12:33 pm

Formulário de Pesquisa

Mensagem por mariogus »

Tomas..utilizando o modelo de cadastro..tentei adaptar para a minha planilha..mas alguns dos campos não estão funcionando..podes me ajudar

CODE

Rem Attribute VBA_ModuleType=VBAFormModule
Option VBASupport 1
Sub frmPesquisa
Rem Option Explicit
Rem 'constantes para auxiliar na verificação do código
Rem Private Const Ascendente As Byte = 0
Rem Private Const Descendente As Byte = 1
Rem
Rem Private Sub btnFiltrar_Click()
Rem
Rem Call PopulaListBox(txtEmpresa.Text, txtAtuacao.Text, txtNomeFantasia.Text, txtRazaoSocial.Text, txtCidade.Text, txtRegiao.Text)
Rem
Rem End Sub
Rem
Rem Private Sub frmFiltros_Click()
Rem
Rem End Sub
Rem
Rem Private Sub lstLista_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Rem If lstLista.ListIndex > 0 Then
Rem Dim indiceRegistro As Long
Rem indiceRegistro = frmCadastro.ProcuraIndiceRegistroPodId(lstLista.List(lstLista.ListIndex, 0))
Rem If indiceRegistro <> -1 Then
Rem Call frmCadastro.CarregaRegistroPorIndice(indiceRegistro)
Rem End If
Rem Unload Me
Rem Else
Rem lblMensagens.Caption = "É preciso selecionar um item válido na lista"
Rem End If
Rem End Sub
Rem
Rem Private Sub UserForm_Initialize()
Rem
Rem 'preenche o cboDirecao e seleciona o primeiro item
Rem cboDirecao.Clear
Rem cboDirecao.AddItem "Ascendente"
Rem cboDirecao.AddItem "Descendente"
Rem cboDirecao.ListIndex = 0
Rem
Rem Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)
Rem
Rem End Sub
Rem
Rem Private Sub PopulaListBox(ByVal Empresa As String, _
Rem ByVal Atuacao As String, _
Rem ByVal NomeFantasia As String, _
Rem ByVal RazaoSocial As String, _
Rem ByVal Cidade As String, _
Rem ByVal Regiao As String)
Rem
Rem On Error GoTo TrataErro
Rem
Rem Dim conn As ADODB.Connection
Rem Dim rst As ADODB.Recordset
Rem Dim sql As String
Rem Dim sqlWhere As String
Rem Dim sqlOrderBy As String
Rem Dim i As Integer
Rem Dim campo As Field
Rem Dim myArray() As Variant
Rem
Rem Set conn = New ADODB.Connection
Rem With conn
Rem .Provider = "Microsoft.JET.OLEDB.4.0"
Rem .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"
Rem .Open
Rem End With
Rem
Rem sql = "SELECT * FROM [Fornecedor$]"
Rem
Rem 'monta a cláusula WHERE
Rem 'NomeDaEmpresa
Rem Call MontaClausulaWhere(txtEmpresa.Name, "Empresa", sqlWhere)
Rem
Rem 'Nome da Área de Atuação
Rem Call MontaClausulaWhere(txtAtuacao.Name, "Atuacao", sqlWhere)
Rem
Rem 'Nome Fantasia
Rem Call MontaClausulaWhere(txtNomeFantasia.Name, "NomeFantasia", sqlWhere)
Rem
Rem 'Razão Social
Rem Call MontaClausulaWhere(txtRazaoSocial.Name, "RazaoSocial", sqlWhere)
Rem
Rem 'Cidade
Rem Call MontaClausulaWhere(txtCidade.Name, "Cidade", sqlWhere)
Rem
Rem 'Região
Rem Call MontaClausulaWhere(txtRegiao.Name, "Região", sqlWhere)
Rem
Rem 'faz a união da string SQL com a cláusula WHERE
Rem If sqlWhere <> vbNullString Then
Rem sql = sql & " WHERE " & sqlWhere
Rem End If
Rem
Rem 'faz a união da string SQL com a cláusula ORDER BY
Rem If cboOrdenarPor.ListIndex <> -1 Then
Rem sqlOrderBy = " ORDER BY " & cboOrdenarPor.List(cboOrdenarPor.ListIndex, 0)
Rem 'define a direção
Rem Select Case cboDirecao.ListIndex
Rem Case Ascendente
Rem sqlOrderBy = sqlOrderBy & " ASC"
Rem Case Descendente
Rem sqlOrderBy = sqlOrderBy & " DESC"
Rem End Select
Rem 'une a query order ao sql
Rem sql = sql & sqlOrderBy
Rem End If
Rem
Rem Set rst = New ADODB.Recordset
Rem With rst
Rem .ActiveConnection = conn
Rem .Open sql, conn, adOpenDynamic, _
Rem adLockBatchOptimistic
Rem End With
Rem
Rem 'pega o número de registros para atribuí-lo ao listbox
Rem lstLista.ColumnCount = rst.Fields.Count
Rem
Rem 'preenche o combobox com os nomes dos campos
Rem 'persiste o índice
Rem Dim indiceTemp As Long
Rem indiceTemp = cboOrdenarPor.ListIndex
Rem cboOrdenarPor.Clear
Rem For Each campo In rst.Fields
Rem cboOrdenarPor.AddItem campo.Name
Rem Next
Rem 'recupera o índice selecionado
Rem cboOrdenarPor.ListIndex = indiceTemp
Rem
Rem 'coloca as linhas do RecordSet num Array, se houver linhas neste
Rem If Not rst.EOF And Not rst.BOF Then
Rem myArray = rst.GetRows
Rem 'troca linhas por colunas no Array
Rem myArray = Array2DTranspose(myArray)
Rem 'atribui o Array ao listbox
Rem lstLista.List = myArray
Rem 'adiciona a linha de cabeçalho da coluna
Rem lstLista.AddItem , 0
Rem 'preenche o cabeçalho
Rem For i = 0 To rst.Fields.Count - 1
Rem lstLista.List(0, i) = rst.Fields(i).Name
Rem Next i
Rem 'seleciona o primeiro item da lista
Rem lstLista.ListIndex = 0
Rem Else
Rem lstLista.Clear
Rem End If
Rem
Rem 'atualiza o label de mensagens
Rem If lstLista.ListCount <= 0 Then
Rem lblMensagens.Caption = lstLista.ListCount & " registros encontrados"
Rem Else
Rem lblMensagens.Caption = lstLista.ListCount - 1 & " registros encontrados"
Rem End If
Rem
Rem ' Fecha o conjunto de registros.
Rem Set rst = Nothing
Rem ' Fecha a conexão.
Rem conn.Close
Rem
Rem TrataSaida:
Rem Exit Sub
Rem TrataErro:
Rem Debug.Print Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Rem Resume TrataSaida
Rem End Sub
Rem
Rem Private Sub MontaClausulaWhere(ByVal NomeControle As String, ByVal NomeCampo As String, ByRef sqlWhere As String)
Rem 'NomeDoContato
Rem If Trim(Me.Controls(NomeControle).Text) <> vbNullString Then
Rem If sqlWhere <> vbNullString Then
Rem sqlWhere = sqlWhere & " AND"
Rem End If
Rem sqlWhere = sqlWhere & " " & NomeCampo & " LIKE '%" & Trim(Me.Controls(NomeControle).Text) & "%'"
Rem End If
Rem End Sub
Rem
Rem 'Faz a transpasição de um array, transformando linhas em colunas
Rem Private Function Array2DTranspose(avValues As Variant) As Variant
Rem Dim lThisCol As Long, lThisRow As Long
Rem Dim lUb2 As Long, lLb2 As Long
Rem Dim lUb1 As Long, lLb1 As Long
Rem Dim avTransposed As Variant
Rem
Rem If IsArray(avValues) Then
Rem On Error GoTo ErrFailed
Rem lUb2 = UBound(avValues, 2)
Rem lLb2 = LBound(avValues, 2)
Rem lUb1 = UBound(avValues, 1)
Rem lLb1 = LBound(avValues, 1)
Rem
Rem ReDim avTransposed(lLb2 To lUb2, lLb1 To lUb1)
Rem For lThisCol = lLb1 To lUb1
Rem For lThisRow = lLb2 To lUb2
Rem avTransposed(lThisRow, lThisCol) = avValues(lThisCol, lThisRow)
Rem Next
Rem Next
Rem End If
Rem
Rem Array2DTranspose = avTransposed
Rem Exit Function
Rem
Rem ErrFailed:
Rem Debug.Print Err.Description
Rem Debug.Assert False
Rem Array2DTranspose = Empty
Rem Exit Function
Rem Resume
Rem End Function
Rem
Rem
End Sub


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: Formulário de Pesquisa

Mensagem por webmaster »

Mario,

Pode ser mais específico? "alguns dos campos não estão funcionando" não ajuda muito concorda?

Se fez alterações no código, cite quais foram com detalhes para poder ajudar.

Abraços


mariogus
Colaborador
Colaborador
Mensagens: 11
Registrado em: Seg Out 19, 2009 12:33 pm

Re: Formulário de Pesquisa

Mensagem por mariogus »

Desculpe..não fui nada especifico...no userform alterei os textboxes para a minha planilha de Fornecedor e também nas linhas do código abaixo:

Code:

Código: Selecionar todos

Private Sub PopulaListBox(ByVal Empresa As String, _
                          ByVal Atuacao As String, _
                          ByVal NomeFantasia As String, _
                          ByVal RazaoSocial 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 [Fornecedor$]"

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

    'Nome da Área de Atuação
    Call MontaClausulaWhere(txtAtuacao.Name, "Atuacao", sqlWhere)

    'Nome Fantasia
    Call MontaClausulaWhere(txtNomeFantasia.Name, "NomeFantasia", sqlWhere)

    'Razão Social
    Call MontaClausulaWhere(txtRazaoSocial.Name, "RazaoSocial", sqlWhere)

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

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

Inclui a planilha em anexo.


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

Re: Formulário de Pesquisa

Mensagem por webmaster »

Mario,

Qual erro exatamente está ocorrendo? Mudou o nome das colunas na planilha conforme a cláusula SQL? O anexo não veio...

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.


mariogus
Colaborador
Colaborador
Mensagens: 11
Registrado em: Seg Out 19, 2009 12:33 pm

Re: Formulário de Pesquisa

Mensagem por mariogus »

O erro é que quando pesquisa pelos campos selecionados não traz nenhuma informação....Segue o anexo novamente.
Anexos
Metroll_Fornecedores.rar
(73.41 KiB) Baixado 509 vezes


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

Re: Formulário de Pesquisa

Mensagem por webmaster »

Mario,

Como suspeitei, o problema é em relação ao nome dos campos. O código convenciona que o nome do textbox do campo de pesquisa seja o mesmo nome do campo na planilha de dados (sem o txt, claro). No caso, o nome do campo na sua tela de pesquisa era, por exemplo, txtNomeFantasia, mas na planilha o nome da coluna era "Nome Fantasia". Apenas fiz com que os nomes das colunas na planilha de fornecedores fizessem correspondência ao nome dos controles e a tela de pesquisa fucionou perfeitamente.

Faça o teste.

Abraços


mariogus
Colaborador
Colaborador
Mensagens: 11
Registrado em: Seg Out 19, 2009 12:33 pm

Re: Formulário de Pesquisa

Mensagem por mariogus »

Ok.Testei e funcionou perfeitamente.


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