Excel Efetuar pesquisa no vba, na mesma coluna de informações.

[GENECIOFICIAL]

Boa tarde! 

Uso o office 2021.

 

É possível efetuar uma pesquisa no vba, na mesma coluna de informações?

Exemplo: Na célula A2, digito o nome Matos para efetuar a pesquisa,

o VBA após a célula A4, deve exibir todos os nomes com a palavra Matos em qualquer posição na célula, início meio ou fim maiúscula ou minúscula.

 

Mais instruções no anexo.

 

Grato.

PESQUISA COLUNA A.xlsx

[Scofieldgyn]

Olá,

 

Uma dúvida:

Você quer que seja apresentado as respostas na Coluna A, após a célula [A4], porém a lista inteira anterior vai ser apagada, é isso mesmo que quer?

 

 

[GENECIOFICIAL]

Boa tarde!

 

Não os dados fontes devem ser preservados, porém em células ocultas.

Como trata-se de uma pesquisa, quando a célula A2 for vazia, os dados fontes retornam intactos.

 

Muito obrigado.

[Scofieldgyn]

@GENECIOFICIAL

 

Pressione ALT + F11 para abrir o Editor do VBA.

No painel da esquerda, clica duas vezes em “Planilha1 (Planilha1)”.

Cole o código logo abaixo.

 

Obs.: O código abaixo, vai armazenar os nomes originais em memória, toda vez que apagar o fitlro na [A2] os nomes serão restaurados. Importante saber que se Salvar/Fechar o Excel e não tenha apagado o nome de pesquisa, a lista original não voltará ok. 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim termoBusca As String
    Dim i As Long, j As Long
    Dim ultimaLinha As Long
    Static nomesOriginais() As Variant
    Dim nomesTemp As Variant

    ' Executa apenas quando A2 for alterada
    If Not Intersect(Target, Me.Range("A2")) Is Nothing Then
        Application.EnableEvents = False

        termoBusca = Trim(Me.Range("A2").Value)
        
        ' Identifica a última linha com dados na Coluna A (a partir de A4)
        ultimaLinha = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
        If ultimaLinha < 4 Then GoTo Fim ' Nenhum nome disponível
        
        ' Se A2 tem conteúdo: aplica filtro e salva lista original
        If termoBusca <> "" Then
            ' Salva os nomes originais em memória
            nomesOriginais = Me.Range("A4:A" & ultimaLinha).Value
            
            ' Limpa a área de exibição
            Me.Range("A4:A" & ultimaLinha).ClearContents
            
            ' Aplica o filtro
            j = 4
            For i = 1 To UBound(nomesOriginais, 1)
                If LCase(nomesOriginais(i, 1)) Like "*" & LCase(termoBusca) & "*" Then
                    Me.Cells(j, 1).Value = nomesOriginais(i, 1)
                    j = j + 1
                End If
            Next i
        
        ' Se A2 está vazia: restaura a última lista salva
        Else
            If IsArrayAllocated(nomesOriginais) Then
                Me.Range("A4:A" & ultimaLinha).ClearContents
                Me.Range("A4").Resize(UBound(nomesOriginais, 1), 1).Value = nomesOriginais
            End If
        End If
        
Fim:
        Application.EnableEvents = True
    End If
End Sub

' Função auxiliar para verificar se a matriz está alocada
Private Function IsArrayAllocated(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayAllocated = IsArray(arr) And Not IsError(LBound(arr)) And LBound(arr) <= UBound(arr)
End Function

 

[GENECIOFICIAL]

Boa tarde! 

 

Muito obrigado por dispor do seu tempo e conhecimento, na solução do problema.

 

Obs.: O código abaixo, vai armazenar os nomes originais em memória, toda vez que apagar o fitlro na [A2] os nomes serão restaurados. Importante saber que se Salvar/Fechar o Excel e não tenha apagado o nome de pesquisa, a lista original não voltará ok. 

 

 

Entendi a observação.

Minha sugestão: Seria melhor armazenar os dados 100 linhas após os dados da pesquisa e não em memória, evita a perda dos dados,  quando salvar com a célula A2 vazia, mantém a possibilidade de resgatar os nomes.

 

Grato.

[Scofieldgyn]

@GENECIOFICIAL

 

segue:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim termoBusca As String
    Dim i As Long, j As Long
    Dim ultimaLinha As Long, ultimaLinhaBackup As Long
    Dim nomesOriginais As Variant
    Dim ws As Worksheet
    Set ws = Me

    If Not Intersect(Target, ws.Range("A2")) Is Nothing Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False

        termoBusca = Trim(ws.Range("A2").Value)
        
        ultimaLinha = ws.Cells(99, 1).End(xlUp).Row
        If ultimaLinha < 4 Then GoTo Finalizar
        
        If termoBusca <> "" Then
            ws.Range("A4:A" & ultimaLinha).Copy
            ws.Range("A100").PasteSpecial xlPasteValues
            Application.CutCopyMode = False

            ws.Range("A4:A" & ultimaLinha).ClearContents

            ultimaLinhaBackup = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            nomesOriginais = ws.Range("A100:A" & ultimaLinhaBackup).Value

            j = 4
            For i = 1 To UBound(nomesOriginais, 1)
                If LCase(nomesOriginais(i, 1)) Like "*" & LCase(termoBusca) & "*" Then
                    ws.Cells(j, 1).Value = nomesOriginais(i, 1)
                    j = j + 1
                End If
            Next i
        
        Else
            ultimaLinhaBackup = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            If ultimaLinhaBackup >= 100 Then
                nomesOriginais = ws.Range("A100:A" & ultimaLinhaBackup).Value

                ws.Range("A4:A" & ws.Rows.Count).ClearContents

                ws.Range("A4").Resize(UBound(nomesOriginais, 1), 1).Value = nomesOriginais

                ws.Range("A100:A" & ultimaLinhaBackup).ClearContents
            End If
        End If

        ws.Range("A3").Select

Finalizar:
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Sub