Este fórum está sendo desativado

[Mauro]

Boa tarde,

Tenho 4 colunas na sheet(1), coluna A com descrições e B com nomes e tenho a coluna C com descrições e a coluna D com nomes.

Preciso de comparar a contagem de duplicados das colunas com os nomes(B e C) e copiar juntamente com as descrições os nomes se a contagem que existe em cada coluna for diferente.

Exemplo: Na coluna B existe 10 celulas com o valor "Rita" se na coluna D existirem também 10 células com o valor "Rita" então o Excel não faz nada.(vice-versa)

Se, a contagem for diferente, ou seja, na coluna B existem 10 células com o valor "Rita" e na coluna D existem apenas 9(ou vice-versa comparar D com B) então ele copia os valores e descrições para outra folha

Com "Contar.se" e Loop é perfeitamente possível mas por vezes existem mais de 20 000 registros em cada coluna e torna-se muito lento comparar valores de B com D e depois D com B.

Deixo em anexo uma folha em Excel com um exemplo daquilo que preciso.

Obrigado

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub ReplicaDados()
 Dim k As Long, x As Long, b As Long, c As Long, m As Long, LR As Long, e As Long
  Sheets("Analise").Cells.Clear
  With Sheets("Dados")
   For x = 1 To 4 Step 3
    m = IIf(x = 1, 5, 2)
    For k = 1 To .Cells(Rows.Count, x + 1).End(3).Row
     If Application.CountIf(Sheets("Analise").[B:B], .Cells(k, x + 1)) = 0 Then
      b = Application.CountIf(.Columns(x + 1), .Cells(k, x + 1))
      c = Application.CountIf(.Columns(m), .Cells(k, x + 1))
      If b <> c Then
      If Sheets("Analise").[A2] = "" Then
       LR = 0
      Else: LR = Sheets("Analise").Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row
      End If
       .Cells(k, x).Resize(b, 2).Copy Sheets("Analise").Cells(LR + 2, x)
       If c > 0 Then
        e = .Columns(m).Find(.Cells(k, x + 1)).Row
        .Cells(e, m - 1).Resize(c, 2).Copy Sheets("Analise").Cells(LR + 2, m - 1)
       End If
      End If
      k = k + b - 1
     End If
    Next k
   Next x
  End With
End Sub

Como você não informou qual o critério que você adotou para a sequência do resultado então eu adotei processar primeiro A:B e depois C:D, por isso FILIPA aparecerá em último e não em segundo como no seu resultado.

[Mauro]

Boa tarde Osvaldo, mais uma vez agradeço-lhe por toda a sua ajuda e disponibilidade.
Testei o código e não funciona como esperado se, a ordem dos dados estiver desagrupada, ou seja, por exemplo: a RITA aparecer na 1ª posição e duplicada na 5 ou 7 ou 11 posição, peço desculpa por não ter mencionado, é o que acontece a maior parte das vezes.
Já agora, é possível fazer a copia para outra sheet("exclusivos") sem adicionar espaços entre os valores, os valores exclusivos entre as duas colunas, ou seja, se "RITA" ou varias "RITAS" existir(em) na coluna "B" e não existir nenhuma na coluna "E" ou vice-versa ?
Obrigado

[osvaldomp]

... se, a ordem dos dados estiver desagrupada, ...
Isso quer dizer que o seu exemplo não reproduz a situação original.
Disponibilize novos exemplos e o resultado desejado.

... sem adicionar espaços ... ou seja, se "RITA" ou varias "RITAS" existir(em) na coluna "B" e não existir nenhuma na coluna "E" e vice-versa ?
Disponibilize novos exemplos e o resultado desejado.

[Mauro]

Boas, tem toda a razão, desculpe pelo mau exemplo. Segue folha com exatamente aquilo que é pretendido. Obrigado

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub ReplicaDadosV3()
 Dim x As Long, ws As Worksheet, k As Long, LR As Long
  Application.ScreenUpdating = False
  Set ws = Sheets.Add
  Sheets("Exclusivos").Cells.Clear: Sheets("Analise Duplicados").Cells.Clear
  With Sheets("Dados")
   .AutoFilterMode = False
   .[A1:F1] = "hdr"
   .Range("C2:C" & .Cells(Rows.Count, 2).End(3).Row) = "=COUNTIF(E$2:E$20,B2)"
   .Range("A1:F1").AutoFilter 3, "=0"
   .Range("A2:B" & .Cells(Rows.Count, 2).End(3).Row).Copy ws.[A2]
   .ShowAllData
   .Range("F2:F" & .Cells(Rows.Count, 5).End(3).Row) = "=COUNTIF(B$2:B$19,E2)"
   .Range("A1:F1").AutoFilter 6, "=0"
   .Range("D2:E" & .Cells(Rows.Count, 5).End(3).Row).Copy ws.[D2]
   .AutoFilterMode = False
   .Range("A1:F1").AutoFilter 3, ">0"
   .Range("A2:B" & .Cells(Rows.Count, 2).End(3).Row).Copy ws.[H2]
   .ShowAllData
   .Range("A1:F1").AutoFilter 6, ">0"
   .Range("D2:E" & .Cells(Rows.Count, 5).End(3).Row).Copy ws.[K2]
   .AutoFilterMode = False
   .[A1:F1] = "": .[C:C,F:F] = ""
  End With
  With ws
   .[A1:B1,D1:E1,H1:L1] = "hdr"
   .Range("A2:B" & .Cells(Rows.Count, 2).End(3).Row).Sort Key1:=[B1], Order1:=xlAscending
   .Range("D2:E" & .Cells(Rows.Count, 5).End(3).Row).Sort Key1:=[E1], Order1:=xlAscending
   .Range("A2:E" & .[A:E].Find("*", , xlFormulas, , xlRows, xlPrevious).Row).Copy Sheets("Exclusivos").[A2]
   .Range("H2:I" & .Cells(Rows.Count, 9).End(3).Row).Sort Key1:=[I1], Order1:=xlAscending
   For k = 2 To .Cells(Rows.Count, 9).End(3).Row
    If Sheets("Analise Duplicados").[A2] = "" Then LR = 0 Else _
     LR = Sheets("Analise Duplicados").Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row
    x = Application.CountIf(.Columns(9), .Cells(k, 9))
     .Cells(k, 8).Resize(x, 2).Copy Sheets("Analise Duplicados").Cells(LR + 2, 1)
    .Range("K1:L1").AutoFilter 2, .Cells(k, 9)
    .Range("K2:L" & .Cells(Rows.Count, 12).End(3).Row).Copy Sheets("[color=#FF0000]Analise [/color]Duplicados").Cells(LR + 2, 4)
    .ShowAllData
    k = k + x - 1
   Next k
  End With
  Application.DisplayAlerts = False: ws.Delete
End Sub

#
1. antes de testar altere o nome da planilha de Eclusivos para Exclusivos
2. se entendi corretamente o que você quer então no resultado que você publicou faltam 4 nomes: ANGELA, RUTE, RAQUEL e SARA

[Mauro]

Boas,
Não, esses(ANGELA, RUTE, RAQUEL e SARA) não são para incluir, isto porque, a contagem de cada nome nas duas colunas é igual!

cumps

[osvaldomp]

Verdade, esse critério ficou de fora, sorry.

Substitua este trecho
.Cells(k, 8).Resize(x, 2).Copy Sheets("Analise Duplicados").Cells(LR + 2, 1)
.Range("K1:L1").AutoFilter 2, .Cells(k, 9)
.Range("K2:L" & .Cells(Rows.Count, 12).End(3).Row).Copy Sheets("Analise Duplicados").Cells(LR + 2, 4)
.ShowAllData
#
por este, sff ... acrescentei as duas linhas em vermelho
If x <> Application.CountIf(.Columns(12), .Cells(k, 9)) Then
.Cells(k, 8).Resize(x, 2).Copy Sheets("Analise Duplicados").Cells(LR + 2, 1)
.Range("K1:L1").AutoFilter 2, .Cells(k, 9)
.Range("K2:L" & .Cells(Rows.Count, 12).End(3).Row).Copy Sheets("Analise Duplicados").Cells(LR + 2, 4)
.ShowAllData
End If

[Mauro]

Boa tarde Osvaldo, está perfeito. Mais uma vez, obrigado.