Este fórum está sendo desativado

[Arycar]

Pessoal, boa noite.

Estou com dificuldades para desenvolver um código na planilha em anexo que atenda as especificações abaixo:

Na planilha em anexo vcs podem ver que há uma tabela com "Número do comunicado" e "Tipo". Há alguns casos de comunicados com o mesmo número com mais de 1 tipo.
Eu gostaria de criar uma macro que, ao selecionar 2 ou mais critérios, ela me dissesse na celula G3 quantos comunicados respeitam os critérios selecionados.

Ex1:
Criterio = Tipo 1 ; Criterio 2 = Tipo 2 ; Critério 3 = Tipo 3
Nesse caso haveria apenas 1 comunicado que respeitaria esses 3 criterios...seria o comunicado 3.

Ex2:
Criterio 1 = Tipo 2 ; Criterio 2 = Tipo 5 ; Criterio 3 = vazio
Nesse caso haveria apenas 1 comunicado que respeitaria esses dois critérios...seria o comunicado 8. Apesar dele ter 3 tipos, dentre esses 3, há os 2 tipos selecionados no critério.

Abraço e agradeço desde já qualquer ajuda.

[gfranco]

Bom dia.
Veja se o que fiz te ajuda.

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub ContaRegistros()
    Dim d As Long, c As Long, m As Range, nc As Long
      With Sheets("Plan1")
       .AutoFilterMode = False
       .[A:F] = ""
       Range("A3:B" & Cells(Rows.Count, 1).End(3).Row).Copy .[A10]
        For d = 3 To Cells(Rows.Count, 4).End(3).Row
         For c = 4 To 6
          If Cells(d, c) <> "" Then
           .Range("A10:B" & .Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter 2, Cells(d, c)
           .Range("A11:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy .Cells(1, c)
           .AutoFilterMode = False
          End If
        Next c
         For Each m In .Range("D1:D" & .Cells(Rows.Count, 4).End(3).Row)
          If Application.CountIf(.[E:F], m.Value) = Application.CountA(Cells(d, 5).Resize(, 2)) Then nc = nc + 1
         Next m
        Cells(d, 7) = nc: nc = 0: .[D:F] = ""
       Next d
      End With
    End Sub

obs. antes de rodar o código:
1. corrija o conteúdo de B5 ~~~> de Tipo2 ~~~> para Tipo 2
2. insira uma planilha vazia e mantenha seu nome como Plan1 (será utilizada como auxiliar; você pode ocultá-la, se desejar)
Osvaldo

[Arycar]

GFranco: nesse seu exemplo, ele nao identifica os comunicados que atendam aos 3 criterios ao mesmo tempo. Mas obrigado pela ajuda!

Osvaldo: Perfeito! Era exatamente isso que eu queria! Muito Obrigado!
Obs: vc se importaria de ajustar o código para que, sempre que ele identificasse um comunicado que atenda aos critérios, fizesse uma marcação na coluna C na mesma linha do comunicado? Pode ser um " * ". Isso me permitiria identificar os comunicados que atendem ao critério.

Muito obrigado a todos pela ajuda!

[osvaldomp]

Veja se esta solução ajuda.
Coloque na coluna H uma sequência de IDs para identificar cada grupo de critérios. Por exemplo coloque em H3 = AA100 e arraste para baixo. Então AA100 identifica o grupo de critérios que está em D3:F3; AA101 identifica os critérios em D4:F4, ...
O código abaixo irá colocar na coluna C a ID correspondente ao grupo de critérios em que o Comunicado foi enquadrado.
Substitua o código anterior pelo código abaixo.

Código: Selecionar todos

Sub ContaRegistros()
 Dim d As Long, c As Long, m As Range, nc As Long, h As Range, fAd As String
  With Sheets("Plan1")
   .AutoFilterMode = False
   .[A:F] = ""
   Range("A3:B" & Cells(Rows.Count, 1).End(3).Row).Copy .[A10]
    For d = 3 To Cells(Rows.Count, 4).End(3).Row
     For c = 4 To 6
      If Cells(d, c) <> "" Then
       .Range("A10:B" & .Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter 2, Cells(d, c)
       .Range("A11:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy .Cells(1, c)
       .AutoFilterMode = False
      End If
    Next c
     For Each m In .Range("D1:D" & .Cells(Rows.Count, 4).End(3).Row)
      If Application.CountIf(.[E:F], m.Value) = Application.CountA(Cells(d, 5).Resize(, 2)) Then
       nc = nc + 1
       Set h = Range("A4:A" & Cells(Rows.Count, 1).End(3).Row).Find(m.Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not h Is Nothing Then
         fAd = h.Address
         Do
          h.Offset(, 2).Value = Cells(d, 8)
          Set h = Range("A4:A" & Cells(Rows.Count, 1).End(3).Row).FindNext(h)
         Loop While Not h Is Nothing And h.Address <> fAd
        End If
      End If
     Next m
    Cells(d, 7) = nc: nc = 0: .[D:F] = ""
   Next d
  End With
End Sub

[Arycar]

Perfeito, Osvaldo! Muito obrigado.