amigo Mprudencio.
Ainda nao tenho codigo para esse efeito.
o que procuro acho que é um codigo para autofiltro.pelo menos de onde tirei a ideia é um autofiltro, mas esta so numa panilha do excel.
Mas em anexo envio o ficheiro para perceber a minha ideia,mas transposta para uma Userform com uma combobox e um botao.
Eu ja tenho uma userform onde faço pesquisa por data e nome. se der para adaptar a essa também servia, vou enviar o codigo que tenho na userform de pesquisa
dados no userform de pesquisa com listbox
Private Sub Pesquisar_Click()
Dim vValor As String
If ComboBoxCampos <> "" Then
TextBoxFiltro = ""
vValor = ComboBoxCampos
End If
If TextBoxFiltro <> "" Then
ComboBoxCampos = ""
vValor = TextBoxFiltro
End If
If ComboBoxCampos = "" And TextBoxFiltro = "" Then
MsgBox "Informe um critério para realizar a pesquisa!", vbExclamation, "Erro"
Exit Sub
End If
buscaValor vValor
End Sub
no Module este codigo
'Sub filtraCondutor()
Application.DisplayAlerts = False
With ThisWorkbook
With .Sheets("Folha1")
Dim ultimaLinha As Integer
ultimaLinha = .UsedRange.Rows.Count
Range("B2:B" & ultimaLinha).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
With ThisWorkbook.Sheets(Sheets.Count)
.Activate
.Range("A1").Select
ActiveCell.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A1").Select
ultimaLinha = .UsedRange.Rows.Count
.Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets(Sheets.Count).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(Sheets.Count).Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(Sheets.Count).Sort
.SetRange Range("A1:A" & ultimaLinha)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$A$" & ultimaLinha).RemoveDuplicates Columns:=1, Header:=xlNo
.Range("A1").Select
End With
With frmPesquisa
.ComboBoxCampos.Clear
Dim c As Integer
For c = 1 To Sheets(Sheets.Count).UsedRange.Rows.Count
.ComboBoxCampos.AddItem Cells(c, "A")
Next
End With
ThisWorkbook.Sheets(Sheets.Count).Delete
ThisWorkbook.Sheets("Folha1").Activate
Range("A1").Select
End With
End With
End Sub
Function buscaValor(ByVal vValor As String)
With frmPesquisa
DoEvents
Application.ScreenUpdating = False
.ListBoxLista.Clear
ThisWorkbook.Sheets("Folha1").Activate
On Error GoTo vErro
If frmPesquisa.ComboBoxCampos <> "" Then
Columns("B:B").Select
Selection.Find(CStr(vValor), ActiveCell, xlValues, xlPart, xlByRows, xlNext).Activate
Else
Columns("D:D").Select
Selection.Find(CStr(vValor), ActiveCell, xlValues, xlPart, xlByRows, xlNext).Activate
End If
Dim c As Integer
For c = 2 To ActiveSheet.UsedRange.Rows.Count
Cells(c, ActiveCell.Column).Select
If ActiveCell <> Empty Then
Dim vStr As String
vStr = ActiveCell.Value
If StrConv(vStr, vbLowerCase) Like "*" & StrConv(vValor, vbLowerCase) & "*" Then
.ListBoxLista.AddItem Cells(c, "A").Text
.ListBoxLista.List(.ListBoxLista.ListCount - 1, 1) = Cells(c, "B").Text
.ListBoxLista.List(.ListBoxLista.ListCount - 1, 2) = Cells(c, "C").Text
.ListBoxLista.List(.ListBoxLista.ListCount - 1, 3) = Cells(c, "D").Text
.ListBoxLista.List(.ListBoxLista.ListCount - 1, 4) = Cells(c, "E").Text
.ListBoxLista.List(.ListBoxLista.ListCount - 1, 5) = Cells(c, "F").Text
.ListBoxLista.List(.ListBoxLista.ListCount - 1, 6) = Cells(c, "G").Text
.ListBoxLista.List(.ListBoxLista.ListCount - 1, 7) = Cells(c, "H").Text
End If
Else
Exit Function
End If
Next c
.TextBoxFiltro.SetFocus
Application.ScreenUpdating = True
Exit Function
vErro:
If Err = 91 Then
frmPesquisa.ListBoxLista.Clear
frmPesquisa.TextBoxFiltro.SetFocus
Application.ScreenUpdating = True
Exit Function
End If
End With
End Function
a ideia é tipo o do ficheiro que encontrei na net mas ao colocar o nome ele fazer a pesquisa e depois dar um PrintPreview com uma folha igual ao formato da folha 1 mas so com o resultado .
Postado : 07/03/2016 12:56 pm