Ir para conteúdo
Pedro_Gomes

Problemas com Pesquisar com filtros de pesquisa em VBA

Recommended Posts

Sou estudante de Programação e nunca tinha usado VBA e tenho de entregar um trabalho, mas nunca tive formação nesta linguagem, e estou a ter problemas  no programa na parte de Pesquisar registros com filtros, já tentei ao máximo fazer seguindo tutoriais na internet, até que uma pessoua me ajudou e mandou-me codia e disse para fazer um passos só que eu nao sei seguir esses passos.

 Fico muito agradecido se alguém me conseguir ajudar.

   

O que a pessoa me indicou:

" Para testar o código coloque um filtro na planilha Dados no range A1:L1 e crie uma planilha com o nome de Auxiliar. Cole o código no formulário Pesquisar. "

 

Option Explicit

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then Call Filtro(TextBox1.Text, ComboBox1.Text)
End Sub

Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then Call Filtro(TextBox2.Text, ComboBox2.Text)
End Sub

Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then Call Filtro(TextBox3.Text, ComboBox3.Text)
End Sub

Private Sub UserForm_Initialize()
    ComboBox1.RowSource = "Relatório!A1:A12"
    ComboBox2.RowSource = "Relatório!A1:A12"
    ComboBox3.RowSource = "Relatório!A1:A12"
End Sub

Sub Filtro(ByVal Pesquisa As String, Campo As String)
    Dim Coluna  As Integer
    Dim Area    As Range
    
    Set Area = ThisWorkbook.Sheets("Dados").[A1:L1]
    Coluna = WorksheetFunction.Match(Campo, Area, 0)
    If Pesquisa <> "" Then
        If IsNumeric(Pesquisa) = False Then Pesquisa = "*" & Pesquisa & "*"
        Call Area.AutoFilter(Field:=Coluna, Criteria1:=Pesquisa)
        Call CopiaTabela
        Call PreencheListBox
    End If
End Sub

Sub CopiaTabela()
    ThisWorkbook.Sheets("Auxiliar").[A:L].Clear
    ThisWorkbook.Sheets("Dados").[A1].CurrentRegion.Copy
    ThisWorkbook.Sheets("Auxiliar").[A1].PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End Sub

Sub PreencheListBox()
    Dim Area    As Range
    Set Area = ThisWorkbook.Sheets("Auxiliar").[A1].CurrentRegion
    ListBox1.ColumnCount = Area.Columns.Count
    ListBox1.ColumnHeads = True
    ListBox1.RowSource = "Auxiliar!" & Area.Offset(1).Address
End Sub

Link do Programa: 

https://drive.google.com/file/d/1ucJVL5Ijg0IcDqaFzoJi8aiMPb0NCbjI/view?usp=sharing

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar Agora

  • Conteúdo Similar

    • Por gereiz
      Bom dia a todos. Adaptei um código para renomear vários arquivo com vba, que realiza a seguinte função:
       
      1) Eu seleiono a pasta,
      2) O VBA abre o PDF (Nota fiscal) , extrai a informação do texto e com a razão social fecha o pdf e renomeia ele com o nome extraido.
       
      O problema é que após renomear o primeiro arquivo corretamente a execução do código trava, e é necessário finalizar o processo.
      Segue abaixo o código.
      Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) Public Function ListaArquivos(ByVal Caminho As String) As String()          'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime     Dim FSO As New FileSystemObject     Dim result() As String     Dim Pasta As Folder     Dim Arquivo As File     Dim Indice As Long         ReDim result(0) As String     If FSO.FolderExists(Caminho) Then         Set Pasta = FSO.GetFolder(Caminho)           For Each Arquivo In Pasta.Files             Indice = IIf(result(0) = "", 0, Indice + 1)             ReDim Preserve result(Indice) As String             result(Indice) = Arquivo.Name         Next     End If       ListaArquivos = result ErrHandler:     Set FSO = Nothing     Set Pasta = Nothing     Set Arquivo = Nothing End Function Private Sub selecionar_pasta()  Dim box As Folder  Dim arquivos() As String  Dim lCtr As Long  Dim AdobeApp As String  Dim StartAdobe  Dim Arquivo As String  Dim NomeAntigo As String  Dim NomeNovo As String        On Error Resume Next      linha = 1      ultima_linha = Sheets("teste").Cells(Rows.Count, 1).End(xlUp).Row                  With Application.FileDialog(msoFileDialogFolderPicker)             .Title = "Buscar pasta"             .InitialFileName = ThisWorkbook.Path             .Show             .AllowMultiSelect = False             Pasta = .SelectedItems(1)         End With         TextBox1 = box          arquivos = ListaArquivos(Pasta)     Sleep 1000     For lCtr = 0 To UBound(arquivos)       Debug.Print arquivos(lCtr)         'Inserir código aqui'                  'Cells(linha, 1).Value = arquivos(lCtr)         'linha = (linha + 1)         'Sleep 500                                 pdf = arquivos(lCtr)                    AdobeApp = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"                      Sleep 2000                                          For Each pdf In Pasta                                 Adobefile = Pasta & "\" & pdf                    StartAdobe = Shell("" & AdobeApp & " " & """" & Adobefile & """" & "", 1)                              Sleep 2000                                         Application.SendKeys ("^a")             Application.SendKeys ("^c")              Sleep 2000                                    Dim KillPdf As String            KillPdf = "TASKKILL /F /IM AcroRd32.exe"            Shell KillPdf, vbHide                                               AppActivate Application.Caption                                            Sheets("teste").Range("A1").Activate             SendKeys ("^v")                                   DoEvents                                                                     Dim Razao As String             Razao = Sheets("teste").Range("A17").Value             pontos = InStr(1, Razao, ":")             qtdeLetras = Len(Razao)             Nome = Right(Razao, qtdeLetras - pontos)             Sheets("teste").Range("C1").Value = Nome                                                                   Do While Not IsEmpty(Range("C1"))                                              NomeAntigo = Pasta & "\" & pdf                                      NomeNovo = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"                                  Sheets("teste").Range("C2").Value = Adobefile                                      Sheets("teste").Range("C3").Value = Pasta & "\" & Sheets("teste").Range("C1").Value & ".pdf"                                                       Name NomeAntigo As NomeNovo                                                                  ' DoEvents                                         Loop                       ' MsgBox "Nomes dos arquivos alterados!", vbOKOnly, "Processo Concluído"                                                Next                       Next           ' MsgBox ("Arquivos Encontrados = ") & (linha - 1)                    End Sub Já tentei de tudo, e não consegui resolver esse problema, se eu remover o Do while, ele executa normalmente, porem não renomeia os arquivos. Seu eu faço esse laço, ele renomeia só o primeiro e trava geral.
       
      Qualquer esclarecimento, agradeço.

       
    • Por kendy1290
      Olá! Estou com problema referente a exportação de gráficos do Excel via VBA para apresentação do PowerPoint. A maneira que encontrei, inclusive em várias fontes é de exportar vários gráficos de uma vez ou uma ,em uma nova apresentação. O que estou precisando é de exportar os gráficos do Excel em um arquivo do PowerPoint existente, em slides e locais específicos das apresentações. Se alguém tiver alguma  ideia de como fazer seria de muita ajuda. 
    • Por sapinhox
      Tenho um programa desenvolvido em VBA para Autocad, o mesmo tem duas linhas de programação que estão dando o seguinte erro:
       
       
      as linhas que estão dando erro são as seguintes
       
      Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
      Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
       
      Acredito que tenha alguma coisa a ver do fato do sistema instalado ser 64 bits, algum tem alguma solução para o caso.
       
      Desde já agradeço
       

    • Por cesarhtc
      Boa tarde não estou conseguindo rodar o codigo abaixo:

       
      Const IntervaloSegundos = 5 * 60 ' 5 minutos de intervalo Sub Iniciar() Alarme = Now + TimeSerial(0, 0, IntervaloSegundos) Application.OnTime EarliestTime:=Alarme, procedure:="Macro_Atualizar_Tramite_web", schedule:=True End Sub Function Macro_Atualizar_Tramite_web() On Error GoTo Macro_Atualizar_Tramite_web_Err DoCmd.SetWarnings False DoCmd.OpenQuery "CRIAR_TABELA_TRAMITACAO_CONTRATACAO", acViewNormal, acEdit DoCmd.OpenQuery "CRIAR_TABELA_TRAMITACAO_CONSUMO", acViewNormal, acEdit Beep MsgBox "Dados Atualizados!", vbExclamation, "Carga" Macro_Atualizar_Tramite_web_Exit: Exit Function Macro_Atualizar_Tramite_web_Err: MsgBox Error$ Resume Macro_Atualizar_Tramite_web_Exit Call Iniciar End Function Sub Parar() On Error Resume Next Application.OnTime EarliestTime:=Alarme, procedure:="Macro_Atualizar_Tramite_web", schedule:=False End Sub Obrigado
    • Por Fabio de Souza
      Ola amigos é minha primeira vez no forum,
       
      Estou com o seguinte problema:
       
      efetuei uma planilha em vba excel, porem em uma determinada textbox, estou tendo dor de cabeça,
      fiz uma tabela que busca de valores e insere de valores.
       
      Na tabela fde inserção de valores, tudo, ok
      efetuei a formula com comando Cdate(textde) - quando preenche a mesma ela inserre corretamente em formato de datas porem,
      na  busca de valores quando a celula na estão preenchida ele nãos tras nada nesta txtDE, e quando eu efetuo a alteração ele da erro,
      porque na opção "Cdade" tem que esdta preenchida com alguma coisa...
       
       
      consegume me ajudar?
      ' este faz a busca de valores:
       
      Private Sub txtLocaliza_AfterUpdate()
      Dim intervalo As Range
      Dim texto As String
      Dim codigo As Integer
      Dim pequisa
      Dim mensagem
          codigo = txtLocaliza.Value
      'Sheets("Clientes").Select
      Set intervalo = Sheets("Clientes").Range("A:Y")
      On Error GoTo trataErro
      pesquisa = Application.WorksheetFunction.VLookup(codigo, intervalo, 2, False)
      pesq1 = Application.WorksheetFunction.VLookup(codigo, intervalo, 3, False)
      pesq2 = Application.WorksheetFunction.VLookup(codigo, intervalo, 4, False)
      pesq3 = Application.WorksheetFunction.VLookup(codigo, intervalo, 5, False)
      pesq4 = Application.WorksheetFunction.VLookup(codigo, intervalo, 6, False)
      pesq5 = Application.WorksheetFunction.VLookup(codigo, intervalo, 7, False)
      pesq6 = Application.WorksheetFunction.VLookup(codigo, intervalo, 8, False)
      pesq7 = Application.WorksheetFunction.VLookup(codigo, intervalo, 9, False)
      pesq8 = Application.WorksheetFunction.VLookup(codigo, intervalo, 10, False)
      pesq9 = Application.WorksheetFunction.VLookup(codigo, intervalo, 11, False)
      pesq10 = Application.WorksheetFunction.VLookup(codigo, intervalo, 12, False)
      pesq11 = Application.WorksheetFunction.VLookup(codigo, intervalo, 13, False)
      pesq12 = Application.WorksheetFunction.VLookup(codigo, intervalo, 14, False)
      pesq13 = Application.WorksheetFunction.VLookup(codigo, intervalo, 15, False)
      pesq14 = Application.WorksheetFunction.VLookup(codigo, intervalo, 16, False)
      pesq15 = Application.WorksheetFunction.VLookup(codigo, intervalo, 17, False)
      pesq16 = Application.WorksheetFunction.VLookup(codigo, intervalo, 18, False)
      pesq17 = Application.WorksheetFunction.VLookup(codigo, intervalo, 19, False)
      pesq18 = Application.WorksheetFunction.VLookup(codigo, intervalo, 20, False)
      pesq19 = Application.WorksheetFunction.VLookup(codigo, intervalo, 21, False)
      pesq20 = Application.WorksheetFunction.VLookup(codigo, intervalo, 22, False)
      pesq21 = Application.WorksheetFunction.VLookup(codigo, intervalo, 23, False)
      pesq22 = Application.WorksheetFunction.VLookup(codigo, intervalo, 24, False)
      pesq23 = Application.WorksheetFunction.VLookup(codigo, intervalo, 25, False)
      pesq24 = Application.WorksheetFunction.VLookup(codigo, intervalo, 1, False)
      lblCod = pesq24
      txtAddress = CDate(pesquisa)
      txtNumber = pesq1
      txtNeighb = pesq2
      txtCity = pesq3
      cbUF = pesq4
      txtDDD1 = Format(CCur(pesq5), "#0.000")
      txtPhone1 = Format(CCur(pesq6), "#0.000")
      txtDDD2 = Format(CCur(pesq7), "#0.000")
      txtPhone2 = Format(CCur(pesq8), "#0.000")
      txtEmail = Format(CCur(pesq9), "#0.000")
      txtmn = Format(CCur(pesq10), "#0.000")
      txtti = Format(CCur(pesq11), "#0.000")
      txtal = Format(CCur(pesq12), "#0.000")
      txtcomplemento = pesq13
      If pesq14 <> "" Then
      txtDT = CDate(pesq14)
      End If
      txtIN = pesq15
      txtTR = pesq16
      ''If pesq17 <> "" Then
      txtPeso = Format(CCur(pesq17), "###,##0.000")
      ''End If
      txtPecas = pesq18
      ''If pesq19 <> "" Then
      txtPB = Format(CCur(pesq19), "###,##0.000")
      ''End If
      ''If pesq20 <> "" Then
      txtPL = Format(CCur(pesq20), "###,##0.000")
      ''End If
      If pesq21 <> "" Then
      txtDE = CDate(pesq21)
      End If
      txtDS = pesq22
      txtVT = pesq23
      Exit Sub
      trataErro:
         texto = "Não Localizado"
         mensagem = MsgBox(texto, vbOKOnly + vbInformation)
      End Sub
       
      'este altera na tabela
       
      Sub lsAlterarStudent()
          
          'Define a Range de Pesquisa
          Set currentFind = Worksheets("Clientes").Range("A:A").Find(frmCadastroStudents.lblCod, , _
              Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
              Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
              
          lLinha = currentFind.Row
          
          With frmCadastroStudents
              Sheets("Clientes").Cells(lLinha, 2).Value = CDate(.txtAddress)
              Sheets("Clientes").Cells(lLinha, 3).Value = .txtNumber
              Sheets("Clientes").Cells(lLinha, 4).Value = .txtNeighb
              Sheets("Clientes").Cells(lLinha, 5).Value = .txtCity
              Sheets("Clientes").Cells(lLinha, 6).Value = .cbUF
              Sheets("Clientes").Cells(lLinha, 7).Value = CCur(.txtDDD1)
              Sheets("Clientes").Cells(lLinha, 8).Value = CCur(.txtPhone1)
              Sheets("Clientes").Cells(lLinha, 9).Value = CCur(.txtDDD2)
              Sheets("Clientes").Cells(lLinha, 10).Value = CCur(.txtPhone2)
              Sheets("Clientes").Cells(lLinha, 11).Value = CCur(.txtEmail)
              Sheets("Clientes").Cells(lLinha, 12).Value = CCur(.txtmn)
              Sheets("Clientes").Cells(lLinha, 13).Value = CCur(.txtti)
              Sheets("Clientes").Cells(lLinha, 14).Value = CCur(.txtal)
              Sheets("Clientes").Cells(lLinha, 15).Value = .txtcomplemento
              Sheets("Clientes").Cells(lLinha, 16).Value = CDate(.txtDT)
              Sheets("Clientes").Cells(lLinha, 17).Value = .txtIN
              Sheets("Clientes").Cells(lLinha, 18).Value = .txtTR
              
          ''If txtPeso <> "" Then
              Sheets("Clientes").Cells(lLinha, 19).Value = CCur(.txtPeso)
          ''End If
              
              Sheets("Clientes").Cells(lLinha, 20).Value = .txtPecas
                      
          ''If txtPB <> "" Then
              Sheets("Clientes").Cells(lLinha, 21).Value = CCur(.txtPB)
          ''End If
              
          ''If txtPL <> "" Then
              Sheets("Clientes").Cells(lLinha, 22).Value = CCur(.txtPL)
          ''End If
              
          ''If txtDE <> "" Then
              Sheets("Clientes").Cells(lLinha, 23).Value = CDate(.txtDE)
          ''End If
          
              Sheets("Clientes").Cells(lLinha, 24).Value = .txtDS
              Sheets("Clientes").Cells(lLinha, 25).Value = .txtVT
              
          End With
      End Sub
       
       
×

Informação importante

Ao usar o fórum, você concorda com nossos Termos e condições.