Primeiramente obrigado joseA pela resposta, porem ja tentei colocar a sua sugestao no codigo do meu formulario de pesquisa porem nao funcionou, talves eu esteja colocando em um lugar errado! Segue abaixo o codigo do meu formulario de pesquisa!
Código: Selecionar todos
Option Explicit
'constantes para auxiliar na verificação do código
Private Const Ascendente As Byte = 0
Private Const Descendente As Byte = 1
Private caminhoArquivoDados As String
'INICIO - REDIMENSIONAR AUTOMATICAMENTE COLUNAS DO LISTVIEW
'TamanhoColAutomatico - 'Define os Tamanhos das colunas automaticamente
'http://www.vb6.com.br/29/Controles-Microsoft/visual-basic-REDIMENSIONAR-AUTOMATICAMENTE-COLUNAS-DO-LISTVIEW.html
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const LVM_FIRST = &H1000
Private Const LVM_SETCOLUMNWIDTH = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE = -1
Private Const LVSCW_AUTOSIZE_USEHEADER = -2
'FIM - REDIMENSIONAR AUTOMATICAMENTE COLUNAS DO LISTVIEW
Private Sub btnExportar_Click()
Call Exportar
End Sub
Private Sub btnFiltrar_Click()
Call PopulaListBox(txtNomeEmpresa.Text, txtNomeContato.Text, txtEndereco.Text, txtTelefone.Text, txtRegiao.Text, TextBox1.Text, TextBox2.Text, TextBox3.Text, TextBox4.Text, TextBox5.Text, TextBox6.Text, TextBox7.Text, TextBox8.Text, TextBox9.Text, TextBox10.Text, TextBox11.Text)
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
TextBox1.Text = "Ja"
Else
TextBox1.Text = ""
End If
End Sub
Private Sub CheckBox10_Click()
If CheckBox10.Value = True Then
TextBox10.Text = "Ja"
Else
TextBox10.Text = ""
End If
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
TextBox2.Text = "Ja"
Else
TextBox2.Text = ""
End If
End Sub
Private Sub CheckBox3_Click()
If CheckBox3.Value = True Then
TextBox3.Text = "Ja"
Else
TextBox3.Text = ""
End If
End Sub
Private Sub CheckBox4_Click()
If CheckBox4.Value = True Then
TextBox4.Text = "Ja"
Else
TextBox4.Text = ""
End If
End Sub
Private Sub CheckBox5_Click()
If CheckBox5.Value = True Then
TextBox5.Text = "Ja"
Else
TextBox5.Text = ""
End If
End Sub
Private Sub CheckBox6_Click()
If CheckBox6.Value = True Then
TextBox6.Text = "Ja"
Else
TextBox6.Text = ""
End If
End Sub
Private Sub CheckBox7_Click()
If CheckBox7.Value = True Then
TextBox7.Text = "Ja"
Else
TextBox7.Text = ""
End If
End Sub
Private Sub CheckBox8_Click()
If CheckBox8.Value = True Then
TextBox8.Text = "Ja"
Else
TextBox8.Text = ""
End If
End Sub
Private Sub CheckBox9_Click()
If CheckBox9.Value = True Then
TextBox9.Text = "Ja"
Else
TextBox9.Text = ""
End If
End Sub
Private Sub frmFiltros_Click()
End Sub
Private Sub lstLista_DblClick()
Dim linha, Index
Dim i As Integer
Dim oList As Object
Dim indiceRegistro As Long
On Error Resume Next
Set oList = lstLista.SelectedItem
If oList Is Nothing Then 'Exit Sub
lblMensagens.Caption = ""
Else
indiceRegistro = frmCadastro.ProcuraIndiceRegistroPodId(lstLista.ListItems.Item(lstLista.SelectedItem.Index))
If indiceRegistro <> -1 Then
Call frmCadastro.CarregaRegistroPorIndice(indiceRegistro)
End If
End If
frmCadastro.Show
End Sub
Private Sub DefinePlanilhaDados()
Dim wb As Workbook
Dim caminhoCompleto As String
Dim ARQUIVO_DADOS As String
Dim PASTA_DADOS As String
ThisWorkbook.Activate
ARQUIVO_DADOS = Range("ARQUIVO_DADOS").Value
PASTA_DADOS = Range("PASTA_DADOS").Value
If ThisWorkbook.Name <> ARQUIVO_DADOS Then
'monta a string do caminho completo
If PASTA_DADOS = vbNullString Or PASTA_DADOS = "" Then
caminhoCompleto = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, vbNullString) & ARQUIVO_DADOS
Else
If Right(PASTA_DADOS, 1) = "\" Then
caminhoCompleto = PASTA_DADOS & ARQUIVO_DADOS
Else
caminhoCompleto = PASTA_DADOS & "\" & ARQUIVO_DADOS
End If
End If
End If
caminhoArquivoDados = caminhoCompleto
End Sub
Private Sub txtNomeContato_Change()
End Sub
Private Sub UserForm_Initialize()
'lv.ListItems.Clear 'Clear ListView from previous filled data
lstLista.ColumnHeaders.Clear 'Clear the Column Headers
lstLista.ListItems.Clear
With lstLista
.Gridlines = True
.View = lvwReport
' .FullRowSelect
.ColumnHeaders.Add Text:="Code", Width:=20
.ColumnHeaders.Add Text:="Firma", Width:=100
'.ColumnHeaders.Add Text:="Endereço", Width:=120
'.ColumnHeaders.Add Text:="FONE", Width:=30
'.ColumnHeaders.Add Text:="CIDADE", Width:=50
End With
'preenche o cboDirecao e seleciona o primeiro item
cboDirecao.Clear
cboDirecao.AddItem "Ascendente"
cboDirecao.AddItem "Descendente"
cboDirecao.ListIndex = 0
Call DefinePlanilhaDados
Call PopulaCidades
Call PopulaListBox(vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString, vbNullString)
End Sub
Private Sub Exportar()
Dim i As Integer
Dim NewWorkBook As Workbook
Dim rst As ADODB.Recordset
' Preenche o RecordSet com os filtros atuais
Set rst = PreecheRecordSet(txtNomeEmpresa.Text, txtNomeContato.Text, txtEndereco.Text, txtTelefone.Text, txtRegiao.Text, TextBox1.Text, TextBox2.Text, TextBox3.Text, TextBox4.Text, TextBox5.Text, TextBox6.Text, TextBox7.Text, TextBox8.Text, TextBox9.Text, TextBox10.Text, TextBox11.Text)
'cria um novo Workbook
Set NewWorkBook = Application.Workbooks.Add
' Efetua loop em todos os campos, retornando os nomes de campos
' à planilha.
For i = 0 To rst.Fields.Count - 1
NewWorkBook.Sheets(1).Range("A1").Offset(0, i).Value = rst.Fields(i).Name
Next i
NewWorkBook.Sheets(1).Range("A2").CopyFromRecordset rst
NewWorkBook.Activate
End Sub
Private Sub PopulaCidades()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sql As String
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source=" & caminhoArquivoDados & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT DISTINCT Cidade FROM [Fornecedores$]"
Set rst = New ADODB.Recordset
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenDynamic, _
adLockBatchOptimistic
End With
Do While Not rst.EOF
If Not IsNull(rst(0).Value) Then
lstCidades.AddItem rst(0).Value
End If
rst.MoveNext
Loop
' Fecha o conjunto de registros.
Set rst = Nothing
' Fecha a conexão.
conn.Close
End Sub
Private Sub PopulaListBox(ByVal NomeEmpresa As String, _
ByVal NomeContato As String, _
ByVal Endereco As String, _
ByVal Telefone As String, _
ByVal Regiao As String, _
ByVal equip As String, _
ByVal Sattelauflieger As String, _
ByVal Megatrailer As String, _
ByVal Gliederzug As String, _
ByVal Maxx As String, _
ByVal Coilmulde As String, _
ByVal Schwertransporter As String, _
ByVal ISO As String, _
ByVal guttransporte As String, _
ByVal Luftfracht As String, _
ByVal Land As String)
On Error GoTo TrataErro
Dim rst As ADODB.Recordset
Dim campo As Field
Dim myArray() As Variant
Dim i As Integer
Dim li As ListItem, fld As Field, ch As ColumnHeader
Dim Column As Long
Dim Counter As Long
Counter = 0
Set rst = PreecheRecordSet(NomeEmpresa, NomeContato, Endereco, Telefone, Regiao, equip, Sattelauflieger, Megatrailer, Gliederzug, Maxx, Coilmulde, Schwertransporter, ISO, guttransporte, Luftfracht, Land)
'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
'Colunas a Preencher Inicia na Primeira
For i = 2 To rst.Fields.Count - 101 'For i = 1 : a partir da 2ª coluna
Set ch = lstLista.ColumnHeaders.Add(, , rst.Fields(i).Name)
'ch.Width = 48 'Define o Tamanho de Todas as COLUNAS
'MsgBox rst.Fields(i).Name
Next
'Clear the Column Headers
lstLista.ListItems.Clear
'coloca as linhas do RecordSet num Array, se houver linhas neste
If Not rst.BOF Then
Do While Not rst.EOF
'Preenche o LISTVIEW a partir da 2ª Coluna
'Set li = lstLista.ListItems.Add(, "k" & rst.Fields(0), CheckNull(rst.Fields(1)))
'Fill in the rest of the columns
'For i = 2 To rst.Fields.Count - 1
'li.SubItems(i - 1) = CheckNull(rst.Fields(i))
'Preenche o LISTVIEW a partir da 1ª Coluna
Set li = lstLista.ListItems.Add(, "k" & rst.Fields(0), CheckNull(rst.Fields(0)))
'Fill in the rest of the columns
For i = 1 To rst.Fields.Count - 101
li.SubItems(i) = CheckNull(rst.Fields(i))
Next
rst.MoveNext 'Move to next record
Loop
'Define os Tamanhos das colunas automaticamente
Call TamanhoColAutomatico
End If
'atualiza o label de mensagens
If rst.RecordCount <= 0 Then
lblMensagens.Caption = rst.RecordCount & " Lieferant gefunden"
Else
lblMensagens.Caption = rst.RecordCount & " Lieferanten gefunden"
End If
Exit Sub
' 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
MsgBox Err.Description & vbNewLine & Err.Number & vbNewLine & Err.Source
Resume TrataSaida
End Sub
Private Sub TamanhoColAutomatico()
Dim Column As Long
Dim Counter As Long
Counter = 0
For Column = Counter To lstLista.ColumnHeaders.Count - 2
SendMessage lstLista.hWnd, LVM_SETCOLUMNWIDTH, Column, LVSCW_AUTOSIZE_USEHEADER
Next
End Sub
Public Function CheckNull(FieldValue As Variant)
On Error GoTo Error
If IsNull(FieldValue) Then
CheckNull = ""
Else
CheckNull = FieldValue
End If
' Exit Sub
Error:
'GeneralErrors "CheckNull", Err.Number, Err.Description
Resume Next
End Function
Private Function PreecheRecordSet(ByVal NomeEmpresa As String, _
ByVal NomeContato As String, _
ByVal Endereco As String, _
ByVal Telefone As String, _
ByVal Regiao As String, _
ByVal equip As String, _
ByVal Sattelauflieger As String, _
ByVal Megatrailer As String, _
ByVal Gliederzug As String, _
ByVal Maxx As String, _
ByVal Coilmulde As String, _
ByVal Schwertransporter As String, _
ByVal ISO As String, _
ByVal guttransporte As String, _
ByVal Luftfracht As String, _
ByVal Land As String) As Recordset
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=" & caminhoArquivoDados & ";Extended Properties=Excel 8.0;"
.Open
End With
sql = "SELECT * FROM [Fornecedores$]"
'monta a cláusula WHERE
'Firma
Call MontaClausulaWhere(txtNomeEmpresa.Name, "Firma", sqlWhere)
'Straße
Call MontaClausulaWhere(txtEndereco.Name, "Straße", sqlWhere)
'PLZ
Call MontaClausulaWhere(txtNomeContato.Name, "PLZ", sqlWhere)
'Cidade
For i = 1 To lstCidades.ListCount
'verifica se o item está selecionado
If lstCidades.Selected(i - 1) Then
'Monta a cláusula WHERE com OR
Debug.Print lstCidades.List(i - 1) & " selecionado"
If sqlWhere <> vbNullString Then
sqlWhere = sqlWhere & " OR"
End If
sqlWhere = sqlWhere & " UCASE(Cidade) LIKE UCASE('%" & Trim(lstCidades.List(i - 1)) & "%')"
End If
Next
'Anrede
Call MontaClausulaWhere(txtTelefone.Name, "Anrede", sqlWhere)
'Website
Call MontaClausulaWhere(txtRegiao.Name, "Website", sqlWhere)
'Equip
Call MontaClausulaWhere(TextBox1.Name, "equip", sqlWhere)
'Sattelauflieger
Call MontaClausulaWhere(TextBox2.Name, "Sattelauflieger", sqlWhere)
'Megatrailer
Call MontaClausulaWhere(TextBox3.Name, "Megatrailer", sqlWhere)
'Gliederzug
Call MontaClausulaWhere(TextBox4.Name, "Gliederzug", sqlWhere)
'Maxx
Call MontaClausulaWhere(TextBox5.Name, "Maxx", sqlWhere)
'Coilmulde
Call MontaClausulaWhere(TextBox6.Name, "Coilmulde", sqlWhere)
'Schwertransporter
Call MontaClausulaWhere(TextBox7.Name, "Schwertransporter", sqlWhere)
'ISO
Call MontaClausulaWhere(TextBox8.Name, "ISO", sqlWhere)
'guttransporte
Call MontaClausulaWhere(TextBox9.Name, "guttransporte", sqlWhere)
'Luftfracht
Call MontaClausulaWhere(TextBox10.Name, "Luftfracht", sqlWhere)
'Land
Call MontaClausulaWhere(TextBox11.Name, "Land", 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
rst.CursorLocation = adUseClient
With rst
.ActiveConnection = conn
.Open sql, conn, adOpenForwardOnly, _
adLockBatchOptimistic
End With
Set rst.ActiveConnection = Nothing
' Fecha a conexão.
conn.Close
Set PreecheRecordSet = rst
Exit Function
TrataErro:
Set rst = Nothing
End Function
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 & " UCASE(" & NomeCampo & ") LIKE UCASE('%" & 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