Problema com Filtro

[mizeeski]

Boa tarde, tentei alguns códigos para filtrar os clientes, porém nenhum deles teve resultados. tem um Combobox que deveria filtrar os clientes para não ter que passar um por um, e depois de selecionado o Combobox queria poder editar esse mesmo cadastro.

Desde já agradeço a colaboração!

link;

http://www.sendspace.com/file/yk4ck8

[XL Solucoes]

Ola mizeeski,

Posso ter feito de uma forma bem arcaica, mas acho que funcionou da forma que precisa. Antes de tudo, se tiver alguma dúvida, por favor responda ao tópico!

Antes de irmos ao código, adicione na coluna M o campo "linha" e nela preencha com a formula =LIN(). Depois disso crie mais uma aba com o nome de Temp.

Minha ideia foi criar uma base temporária para o filtro selecionado.

As alterações que fiz no código estão identificadas por "bloco ajustado"

Segue o código:

Option Explicit
'define constantes para controlar as colunas de dados

Const colCodigo As Integer = 1
Const colNome As Integer = 2
Const colCpf As Integer = 3
Const colRg As Integer = 4
Const colData As Integer = 5
Const colEndereco As Integer = 6
Const colNum As Integer = 7
Const colCidade As Integer = 8
Const colEstado As Integer = 9
Const colCep As Integer = 10
Const colTelefone As Integer = 11
Const colEmail As Integer = 12
Const indiceMinimo As Byte = 2

'define variavies para controlar a
Private alterar As Boolean
Private novo As Boolean
Private excluir As Boolean

'define as constantes para as cores do textbox
Const corDesabilitaTextBox As Long = -2147483633
Const corHabilitaTextBox As Long = -2147483643

'define a planilha usada e o indice do registro

'''''''''''''''''''''bloco ajustado''''''''''''''''
Public xfiltro As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private wsCadastroClientes As Worksheet
Private indiceRegistro As Long
Private Sub cmdAlterar_Click()

alterar = True
If txtCodigo.Text <> vbNullString And txtCodigo.Text <> "" Then
Call HabilitaControles
Call DesabilitaBotoesAlteracao
'dá o foco ao primeiro controle de dados
txtNome.SetFocus
Else
lblMensagem.Caption = "NÃO HÁ REGISTRO A SER ALTERADO"
End If
End Sub
Private Sub cmdAnterior_Click()

If indiceRegistro > indiceMinimo Then
indiceRegistro = indiceRegistro - 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub cmdCancelar_Click()

cmdOk.Enabled = False
cmdCancelar.Enabled = False
Call DesabilitaControles
Call carregaDados
Call HabilitaBotoesAlteracao
End Sub
Private Sub cmdExcluir_Click()

excluir = True
If txtCodigo.Text <> vbNullString And txtCodigo.Text <> "" Then
Call DesabilitaBotoesAlteracao
lblMensagem.Caption = "VOCÊ CONFIRMA A EXCLUSÃO DESTE REGISTRO? (PARA PARA EXCLUIR CLIQUE NO BOTÃO OK.) "
Else
lblMensagem.Caption = "NÃO EXISTE REGISTRO A SER EXCLUIDO"
End If
End Sub
Private Sub cmdNovo_Click()

novo = True
excluir = False
alterar = False
Call LimpaControles
Call HabilitaControles
Call DesabilitaBotoesAlteracao
'dá o foco ao primeiro controle de dados
txtNome.SetFocus
End Sub
Private Sub CmdOk_Click()


'valida campos do formulário
If ValidaCamposFormulario = False Then
Exit Sub
End If

Dim proximoId As Long

'Alterar registros
If alterar = True Then
Call SalvaRegistro(CLng(txtCodigo.Text), indiceRegistro)
lblMensagem.Caption = "REGISTRO ALTERADO COM SUCESSO."
alterar = False
End If

'Novo registro
If novo = True Then
proximoId = ObterProximoId
'pega a próxima linha
Dim proximoIndice As Long
proximoIndice = wsCadastroClientes.UsedRange.Rows.Count + 1
Call SalvaRegistro(proximoId, proximoIndice)
txtCodigo = proximoId
lblMensagem.Caption = "NOVO REGISTRO SALVO COM SUCESSO."
novo = False
End If

'Excluir um registro
If excluir = True Then
Dim resultado As VbMsgBoxResult
resultado = MsgBox("Deseja excluir o registro nº " & txtCodigo.Text & " ?", vbYesNo, "Confirmação")

If resultado = vbYes Then
wsCadastroClientes.Range(wsCadastroClientes.Cells(indiceRegistro, colCodigo), wsCadastroClientes.Cells(indiceRegistro, colCodigo)).EntireRow.Delete
Call carregaDados
lblMensagem.Caption = "O REGISTRO ESCOLHIDO FOI EXCLUIDO COM SUCESSO."
End If
excluir = False
End If

'''''''''''''''''''''bloco ajustado''''''''''''''''

If wsCadastroClientes.Name = "Temp" Then
Sheets("Temp").Visible = -1
Sheets("Temp").Select
Range("A1").Select
Do
ActiveCell.Offset(1, 0).Select
Loop While ActiveCell & "" <> txtCodigo
indiceRegistro = ActiveCell.Offset(0, 12)
Sheets("Clientes").Select
Sheets("Temp").Visible = 2
Set wsCadastroClientes = ThisWorkbook.Worksheets("Clientes")
alterar = True
Call CmdOk_Click
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Call HabilitaBotoesAlteracao
Call DesabilitaControles


End Sub
Private Sub SalvaRegistro(ByVal id As Long, ByVal indice As Long)

With wsCadastroClientes
.Cells(indice, colCodigo).Value = id
.Cells(indice, colNome).Value = Me.txtNome.Text
.Cells(indice, colEndereco).Value = Me.txtEndereco.Text
.Cells(indice, colCidade).Value = Me.txtCidade.Text
.Cells(indice, colEstado).Value = Me.txtEstado.Text
.Cells(indice, colCep).Value = Me.txtCep.Text
.Cells(indice, colTelefone).Value = Me.txtTelefone.Text
.Cells(indice, colEmail).Value = Me.txtEmail.Text
.Cells(indice, colNum).Value = Me.TxtNum.Text
.Cells(indice, colCpf).Value = Me.TxtCpf.Text
.Cells(indice, colRg).Value = Me.TxtRg.Text
.Cells(indice, colData).Value = Me.TxtData.Text

End With

Call AtualizaRegistroAtual
End Sub
Private Function ObterProximoId() As Long

Dim rangeIds As Range
'pega o range que se refere a toda a coluna do código (id)
Set rangeIds = wsCadastroClientes.Range(wsCadastroClientes.Cells(indiceMinimo, colCodigo), wsCadastroClientes.Cells(wsCadastroClientes.UsedRange.Rows.Count, colCodigo))
ObterProximoId = WorksheetFunction.Max(rangeIds) + 1
End Function
Private Sub cmdPrimeiro_Click()

Call limpaMensagem
indiceRegistro = indiceMinimo
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub cmdProximo_Click()

Call limpaMensagem
If indiceRegistro < wsCadastroClientes.UsedRange.Rows.Count Then
indiceRegistro = indiceRegistro + 1
End If
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub
Private Sub cmdUltimo_Click()

Call limpaMensagem
indiceRegistro = wsCadastroClientes.UsedRange.Rows.Count
If indiceRegistro > 1 Then
Call CarregaRegistro
End If
End Sub



Private Sub txtCep_LostFocus()
If Len(txtCep.Text) = 8 Then
txtCep.Text = Format(txtCep.Text, "00000-000")
End If
End Sub

Private Sub txtCep_Change()

If Len(txtCep.Text) = 8 Then
txtCep.Text = Format(txtCep.Text, "00000-000")
End If
End Sub


Private Sub txtcpf_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

Select Case KeyAscii
Case 8, 48 To 57
Me.TxtCpf.MaxLength = 14 ' Quantidade máxima de caracteres no textbox Cpf
If Len(TxtCpf) = 3 Then TxtCpf = TxtCpf + "."
If Len(TxtCpf) = 7 Then TxtCpf = TxtCpf + "."
If Len(TxtCpf) = 11 Then TxtCpf = TxtCpf + "-"
Case Else
KeyAscii = 0
End Select

End Sub
Private Sub TxtData_Change()

If Len(TxtData) = 2 Or Len(TxtData) = 5 Then
TxtData.Text = TxtData.Text & "/"
SendKeys "{End}", True
End If
End Sub
Private Sub txtteleFone_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

'Limita a Qde de caracteres
txtTelefone.MaxLength = 21

Select Case KeyAscii
Case 8, 48 To 57 ' BackSpace e numericos
If Len(txtTelefone) = 4 Or Len(txtTelefone) = 10 Then
txtTelefone.Text = txtTelefone.Text & "-"
SendKeys "{End}", False

ElseIf Len(txtTelefone) = 9 Then
txtTelefone.Text = txtTelefone.Text & " / "

ElseIf Len(txtTelefone) = 16 Then 'Or Len(txttelefone) = 20 Then
txtTelefone.Text = txtTelefone.Text & "-"
SendKeys "{End}", False
End If

Case Else ' o resto é travado
KeyAscii = 0
End Select

End Sub
Private Sub UserForm_Initialize()

novo = False
alterar = False
excluir = False

'''''''''''''''''''''bloco ajustado''''''''''''''''
If xfiltro = False Then
Set wsCadastroClientes = ThisWorkbook.Worksheets("Clientes")
Else
Set wsCadastroClientes = ThisWorkbook.Worksheets("Temp")
xfiltro = False
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Call HabilitaBotoesAlteracao
Call carregaDados
Call DesabilitaControles
End Sub
Private Sub carregaDados()

indiceRegistro = 2
Call CarregaRegistro

End Sub
Private Sub CarregaRegistro()

'carrega os dados do primeiro registro
With wsCadastroClientes
If Not IsEmpty(.Cells(indiceRegistro, colNome)) Then
Me.txtCodigo.Text = .Cells(indiceRegistro, colCodigo).Value
Me.txtNome.Text = .Cells(indiceRegistro, colNome).Value
Me.txtEndereco.Text = .Cells(indiceRegistro, colEndereco).Value
Me.txtCidade.Text = .Cells(indiceRegistro, colCidade).Value
Me.txtEstado.Text = .Cells(indiceRegistro, colEstado).Value
Me.txtCep.Text = .Cells(indiceRegistro, colCep).Value
Me.txtTelefone.Text = .Cells(indiceRegistro, colTelefone).Value
Me.txtEmail.Text = .Cells(indiceRegistro, colEmail).Value
Me.TxtNum.Text = .Cells(indiceRegistro, colNum).Value
Me.TxtCpf.Text = .Cells(indiceRegistro, colCpf).Value
Me.TxtRg.Text = .Cells(indiceRegistro, colRg).Value
Me.TxtData.Text = .Cells(indiceRegistro, colData).Value
End If
End With

Call AtualizaRegistroAtual
End Sub
Private Sub AtualizaRegistroAtual()

lblRegistro.Caption = indiceRegistro - 1 & " de " & wsCadastroClientes.UsedRange.Rows.Count - 1
'lblMensagem.Caption = ""
End Sub
Private Sub LimpaControles()

Me.txtCodigo.Text = ""
Me.txtNome.Text = ""
Me.txtEndereco.Text = ""
Me.txtCidade.Text = ""
Me.txtEstado.Text = ""
Me.txtCep.Text = ""
Me.txtTelefone.Text = ""
Me.txtEmail.Text = ""
Me.TxtNum.Text = ""
Me.TxtCpf.Text = ""
Me.TxtRg.Text = ""
Me.TxtData.Text = ""
End Sub
Private Sub HabilitaControles()

Me.txtNome.Locked = False
Me.txtEndereco.Locked = False
Me.txtCidade.Locked = False
Me.txtEstado.Locked = False
Me.txtCep.Locked = False
Me.txtTelefone.Locked = False
Me.txtEmail.Locked = False
Me.TxtNum.Locked = False
Me.TxtCpf.Locked = False
Me.TxtRg.Locked = False
Me.TxtData.Locked = False

'altera a cor dos controles

Me.txtNome.BackColor = corHabilitaTextBox
Me.txtEndereco.BackColor = corHabilitaTextBox
Me.txtCidade.BackColor = corHabilitaTextBox
Me.txtEstado.BackColor = corHabilitaTextBox
Me.txtCep.BackColor = corHabilitaTextBox
Me.txtTelefone.BackColor = corHabilitaTextBox
Me.txtEmail.BackColor = corHabilitaTextBox
Me.TxtNum.BackColor = corHabilitaTextBox
Me.TxtCpf.BackColor = corHabilitaTextBox
Me.TxtRg.BackColor = corHabilitaTextBox
Me.TxtData.BackColor = corHabilitaTextBox
End Sub
Private Sub DesabilitaControles()

Me.txtNome.Locked = True
Me.txtEndereco.Locked = True
Me.txtCidade.Locked = True
Me.txtEstado.Locked = True
Me.txtCep.Locked = True
Me.txtTelefone.Locked = True
Me.txtEmail.Locked = True
Me.TxtNum.Locked = True
Me.TxtCpf.Locked = True
Me.TxtRg.Locked = True
Me.TxtData.Locked = True

'altera a cor dos controles

Me.txtNome.BackColor = corDesabilitaTextBox
Me.txtEndereco.BackColor = corDesabilitaTextBox
Me.txtCidade.BackColor = corDesabilitaTextBox
Me.txtEstado.BackColor = corDesabilitaTextBox
Me.txtCep.BackColor = corDesabilitaTextBox
Me.txtTelefone.BackColor = corDesabilitaTextBox
Me.txtEmail.BackColor = corDesabilitaTextBox
Me.TxtNum.BackColor = corDesabilitaTextBox
Me.TxtCpf.BackColor = corDesabilitaTextBox
Me.TxtRg.BackColor = corDesabilitaTextBox
Me.TxtData.BackColor = corDesabilitaTextBox
End Sub
Private Sub HabilitaBotoesAlteracao()

'habilita os botões de alteração
cmdAlterar.Enabled = True
cmdExcluir.Enabled = True
cmdNovo.Enabled = True
cmdOk.Enabled = False
cmdCancelar.Enabled = False
End Sub
Private Sub DesabilitaBotoesAlteracao()

'desabilita os botões de alteração
cmdAlterar.Enabled = False
cmdExcluir.Enabled = False
cmdNovo.Enabled = False
cmdOk.Enabled = True
cmdCancelar.Enabled = True
End Sub
Private Sub cmdPesquisar_Click()
' frmPesquisarClientes.Show
End Sub
Private Function ValidaCamposFormulario() As Boolean

If Me.txtNome.Value = "" Then
Me.txtNome.SetFocus
MsgBox " 'Nome' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtEndereco.Value = "" Then
Me.txtEndereco.SetFocus
MsgBox " 'Endereço' é um campo obrigatório.", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtCidade.Value = "" Then
Me.txtCidade.SetFocus
MsgBox "'Cidade' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtEstado.Value = "" Then
Me.txtCidade.SetFocus
MsgBox "'Estado' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtCep.Value = "" Then
Me.txtCep.SetFocus
MsgBox " 'Cep' é um campo obrigatório. ", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtTelefone.Value = "" Then
Me.txtTelefone.SetFocus
MsgBox "'Telefone' é um campo obrigatório.", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.txtEmail.Value = "" Then
Me.txtEmail.SetFocus
MsgBox "'Email' é um campo obrigatório.", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function

ElseIf Me.TxtCpf.Value = "" Then
Me.TxtCpf.SetFocus
MsgBox "'CPF' é um campo obrigatório.", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.TxtRg.Value = "" Then
Me.TxtRg.SetFocus
MsgBox "'Email' é um campo obrigatório.", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function
ElseIf Me.TxtData.Value = "" Then
Me.TxtData.SetFocus
MsgBox "'Email' é um campo obrigatório.", vbOKOnly, " Campo Obrigatório "
ValidaCamposFormulario = False
Exit Function

End If
ValidaCamposFormulario = True
End Function
Sub limpaMensagem()
lblMensagem.Caption = ""
End Sub

Private Sub ComFiltro_Click()

'''''''''''''''''''''bloco ajustado'''''''''''''''

'copia os dados para uma base temporaria

Application.ScreenUpdating = False

Dim Filtro, ULinha

Filtro = Me.CombFiltro

Sheets("Clientes").Select
Range("A1").Select
If ActiveCell.Offset(1, 0) <> "" Then
Selection.End(xlDown).Select
End If

ULinha = ActiveCell.Row + 1

Range("A1").Select

Selection.AutoFilter
Selection.AutoFilter
ActiveSheet.ListObjects("Tabela1").Range.AutoFilter Field:=2, Criteria1:= _
"=" & Filtro & "", Operator:=xlAnd

Sheets("Temp").Visible = -1 'visivel
Sheets("Temp").Select
Cells.Select
Selection.Delete Shift:=xlUp

Sheets("Clientes").Select

ActiveCell.Range("A1:M" & ULinha & "").Select
Selection.Copy

Sheets("Temp").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Clientes").Select
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter

Sheets("Temp").Visible = 2 'invisivel

xfiltro = True

UserForm_Initialize

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

End Sub

Abraços