Este fórum está sendo desativado

[werlewow]

Bom dia a todos,
Preciso pegar os valores da plan dados e lança-los na plan resultado conforme eu fiz, porém preciso de uma macro para realizar a tarefa. Basicamente seria remover os cód duplicados da 1ª coluna, e transferindo-os para outra planilha.
A grande dificuldade é que essa planilha mostra os códigos de uma peça e por quais processos essa peça vai passar, então analisando o primeiro código M121-204-027 percebe-se que ele é composto por 5 processos, por isso ele se repete 5 vezes, são eles CHFF-05-000 / LASER-05000 / PT-03000 / EMBA-02-001 / EMBA-02-004, preenchidos na coluna D (COD2).
O código PT-03000 se refere a pintura, o que preciso é de uma macro que remova os códigos duplicados, deixando apenas a linha referente ao código da PT e se por ventura não houver o código de pintura, ele deixe qualquer outro código, como mostrei no exemplo na plan resultado.
Outra dificuldade é que o código de pintura pode aparecer como PT-01000, PT-02000 ou ainda PT-03000.

Vejam se conseguem me ajudar

Muito obrigado!

[osvaldomp]

Rode o código abaixo com a planilha dados sendo a planilha ativa.

Código: Selecionar todos

Sub ReplicaDados()
 Dim r As Long, m As Long, p As Range, LR As Long
  LR = Cells(Rows.Count, 1).End(3).Row
  r = 2
  If Sheets("Resultado").[A2] <> "" Then
   Sheets("Resultado").Range("A2:F" & Sheets("Resultado").Cells(Rows.Count, 1).End(3).Row).Value = ""
  End If
  Do
   m = Application.CountIf([A:A], Cells(r, 1))
   If m > 1 Then Set p = Range(Cells(r, 4), Cells(r + m - 1, 4)).Find("PT-")
   If Not p Is Nothing Then
    Cells(p.Row, 1).Resize(, 6).Copy Sheets("Resultado").Cells(Rows.Count, 1).End(3)(2)
   Else: Cells(r, 1).Resize(, 6).Copy Sheets("Resultado").Cells(Rows.Count, 1).End(3)(2)
   End If
   r = r + m: If r >= LR Then Exit Sub
  Loop
End Sub

[werlewow]

Era exatamente isso, obrigado!