Este fórum está sendo desativado

[Gleisom]

Olá, pessoal!

Estou precisando de ajuda para encontrar registros de uma tabela com base em um número ou sequência de números digitados. Estou anexando a planilha e nela tem mais explicações. Desde já agradeço qualquer contribuição. Abraço!

[gfranco]

Amigo,
veja se é isso que precisa....

[Jimmy]

Opsss....

Enquanto eu fazia em VB, o Franco fez via fórmula, que ficou muito bom por sinal.

Segue abaixo a macro. Para inserir a macro:

- Entre na planilha
- Tecle ALT+F11
- Deve abrir a tela de desenvolvimento
- Manu INSERIR e depois MÓDULO
- Copie e cole a macro abaixo na tela grande em branco

Código: Selecionar todos

Sub Compara()
    Set Digi = Range("F4:H4")                           'Faixa de digitação
    Set Posi = Range("B3:D7")                           'Faixa de posições
    Set Codi = Range("A3:A7")                           'Faixa de códigos
    Set Msgs = Range("J4:J" & 4 + 2 + Codi.Rows.Count)  'Faixa de mensagens
    
    Msg = "A faixa de códigos deve conter apenas 1 coluna, e ter a mesma quantidade " & _
          "de linhas que tem a faixa de posições, ou seja, " & Posi.Rows.Count & "."
    If Codi.Columns.Count <> 1 Or Codi.Rows.Count <> Posi.Rows.Count Then MsgBox Msg: GoTo Fim
    Msg = "A faixa de mensagens deve ter no mínimo a mesma quantidade de linhas " & _
          "que a quantidade de códigos, ou seja, " & Codi.Rows.Count & "."
    If Codi.Columns.Count <> 1 Or Codi.Rows.Count <> Posi.Rows.Count Then MsgBox Msg: GoTo Fim
    Qtd = Application.WorksheetFunction.CountA(Digi)
    If Qtd = 0 Then Qtd = 2E+22
    Dim Cont(): ReDim Cont(0 To Posi.Rows.Count)
    For Each CelA In Posi
        For Each CelB In Digi
            If CelA.Value = CelB.Value Then _
               Cont(CelA.Row - Posi.Row + 1) = Cont(CelA.Row - Posi.Row + 1) + 1:    Exit for
        Next
    Next
    
    Msgs.ClearContents
    Lin = 1
    Cont(0) = 0
    For Idx = 1 To UBound(Cont)
        If Cont(Idx) >= Qtd Then
            Lin = Lin + 1:   Cont(0) = Cont(0) + 1
            Msgs.Item(Lin).Value = "Sequencia " & Codi.Item(Idx).Value
        End If
    Next
    If Cont(0) = 0 Then Msgs.Item(1).Value = "Sem registros" _
                   Else Msgs.Item(1).Value = "Encontrado " & Cont(0) & " registros:"
Fim:
Set Digi = Nothing
Set Posi = Nothing
Set Codi = Nothing
Set Msgs = Nothing

End Sub

Procurei deixar a definição das faixas todas no início pra facilitar caso prefira mudar isso.


Insira na planilha um botão de acionamento, ou coloque na execução automática:

- Na tela de desenvolvimento, na coluna da esquerda, dê um duplo-clique sobre o nome da planilha.
- Copie a macro abaixo para área grande em branco.

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("F4:H4")) Is Nothing Then Call Compara
End Sub

Jimmy San Juan

[Gleisom]

Muito obrigado gfranco! Jamais chegaria a uma solução como essa! No caso em que não há nada digitado adaptei suas fórmulas dentro de um SE para retornar " ", porém, nos casos em que digitamos sequências como 1| 1 | 1 ou 1| | 1 continua contabilizando registros e nesses casos não deveria uma vez que essas sequências não constam nos registros. No mais, sua solução é incrível! Parabéns cara!!

[Gleisom]

Jimmy , estou começando agora no excel, não entendo de VB, mas isso que você fez parece mágica! Muito foda essa parada! Parabéns cara! É possível alterar esse código para não contabilizar sequências como | 1 | 1 | | ou | 1 | 1 | 1 | ?

[Jimmy]

Bom dia Gleisom,

Para evitar que 1|1 ou 1|1|1 sejam contabilizados, altere a linha

Cont(CelA.Row - Posi.Row + 1) = Cont(CelA.Row - Posi.Row + 1) + 1
para
Cont(CelA.Row - Posi.Row + 1) = Cont(CelA.Row - Posi.Row + 1) + 1: Exit For

Ainda pode haver problema quando houver número repetido na tabela de Sequencias.
Ex.:
Código 10 1 1 3
Digitado: 1 2

A sequencia 10 será contabilizada. Não sei se no seu sistema são possíveis casos de sequencias repetidas.
Verifique isso e me dê retorno.

Alterei a macro do evento para reprocessar quanto houver qualquer alteração nas sequencias:

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("F4:H4")) Is Nothing Or _
       Not Intersect(Target, Range("B3:D7")) Is Nothing Or _
       Not Intersect(Target, Range("A3:A7")) Is Nothing Then Call Compara
End Sub

Não falamos sobre a forma de você executar a macro, se via botão ou no automático (evento CHANGE da planilha). Se for no automático, podemos transferir todo o código para dentro do evento CHANGE, e o módulo não será mais necessário.

Obs.: Os códigos , as posições e os valores digitados podem não ser números. Pode haver uma sequencia assim:
XYZ 1 D Laranja e se for digitado Laranja D retornará Sequencia XYZ

[Gleisom]

Olá Jimmy!

"Para evitar que 1|1 ou 1|1|1 sejam contabilizados, altere a linha
Cont(CelA.Row - Posi.Row + 1) = Cont(CelA.Row - Posi.Row + 1) + 1para
Cont(CelA.Row - Posi.Row + 1) = Cont(CelA.Row - Posi.Row + 1) + 1: Exit For"

Show!!

"A sequencia 10 será contabilizada. Não sei se no seu sistema são possíveis casos de sequencias repetidas.
Verifique isso e me dê retorno."

Sim. Cai na regra 7 daquelas instruções: "Para ser contabilizada, a sequência digitada deve constar inteiramente em um ou mais registros", ou seja, pode ser repetida, contanto que esteja por inteiro nos registros.

"Não falamos sobre a forma de você executar a macro, se via botão ou no automático (evento CHANGE da planilha). Se for no automático, podemos transferir todo o código para dentro do evento CHANGE, e o módulo não será mais necessário."

Pode ser automático mesmo.

"Obs.: Os códigos , as posições e os valores digitados podem não ser números. Pode haver uma sequencia assim:
XYZ 1 D Laranja e se for digitado Laranja D retornará Sequencia XYZ"

Perfeito cara! Pode me indicar algum canal de video aula sobre VB?

[Jimmy]

Olá Gleisom,

Substitua a macro anterior por esta abaixo.

Código: Selecionar todos

Sub Compara()
    Set Digi = Range("F4:H4")                           'Faixa de digitação
    Set Posi = Range("B3:D7")                           'Faixa de posições
    Set Codi = Range("A3:A7")                           'Faixa de códigos
    Set Msgs = Range("J4:J" & 4 + 2 + Codi.Rows.Count)  'Faixa de mensagens
    
    Msg = "A faixa de códigos deve conter apenas 1 coluna, e ter a mesma quantidade " & _
          "de linhas que tem a faixa de posições, ou seja, " & Posi.Rows.Count & "."
    If Codi.Columns.Count <> 1 Or Codi.Rows.Count <> Posi.Rows.Count Then MsgBox Msg: GoTo Fim
    Msg = "A faixa de mensagens deve ter no mínimo a mesma quantidade de linhas " & _
          "que a quantidade de códigos, ou seja, " & Codi.Rows.Count & "."
    If Codi.Columns.Count <> 1 Or Codi.Rows.Count <> Posi.Rows.Count Then MsgBox Msg: GoTo Fim
    Qtd = Application.WorksheetFunction.CountA(Digi)
    If Qtd = 0 Then Qtd = 2E+22
    Dim Cont(): ReDim Cont(Posi.Rows.Count)
    Dim DigX():   LinAnt = 0
    For Each CelA In Posi
        If CelA.Row <> LinAnt Then      'Uma nova linha de Sequencias está sendo iniciada
            LinAnt = CelA.Row
            ReDim DigX(1 To Digi.Columns.Count)   'Zera matraz cópia de dados
            For Each CelB In Digi       'Faz códia dos dados digitados
                DigX(CelB.Column - Digi.Column + 1) = CelB.Value
            Next
        End If
        For Idx = 1 To UBound(DigX)   'Percorre a cópia dos dados para ver se há igual ao da Sequencia
            If CelA.Value = DigX(Idx) And DigX(Idx) <> "" Then
               Cont(CelA.Row - Posi.Row + 1) = Cont(CelA.Row - Posi.Row + 1) + 1
               DigX(Idx) = ""
               Exit For
            End If
        Next
    Next
    
    Msgs.ClearContents
    Lin = 1
    Cont(0) = 0
    For Idx = 1 To UBound(Cont)
        If Cont(Idx) >= Qtd Then
            Lin = Lin + 1:   Cont(0) = Cont(0) + 1
            Msgs.Item(Lin).Value = "Sequencia " & Codi.Item(Idx).Value
        End If
    Next
    If Cont(0) = 0 Then Msgs.Item(1).Value = "Sem registros" _
                   Else Msgs.Item(1).Value = "Encontrado " & Cont(0) & " registros:"
Fim:
    Set Digi = Nothing
    Set Posi = Nothing
    Set Codi = Nothing
    Set Msgs = Nothing

End Sub

Verifique se assim te atende.

[Gleisom]

Desculpa a demora!! Perfeito Jimmy, parabéns mais uma vez! Obrigado a todos! Abraço!