Bom dia Fabiosp,

Vê se assim ajuda.

Option Explicit
Sub colar()
Dim i       As Long
Dim UltLDad As Long
Dim UltLDup As Long
Dim wb      As Workbook
Dim Dad     As Worksheets
Dim Rel     As Worksheets
Dim Dup     As Worksheets

Set wb = ThisWorkbook
Set Dad = wb.Sheets("dados")
Set Rel = wb.Sheets("relatorio")
Set Dup = wb.Sheets("duplicado")

UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculate = False

    Dad.Range("M17:Q42").Copy
    Rel.Range("A2").PasteSpecial Paste:=xlPasteValues
    MsgBox "Apos Gerar O Relatorio Utilzar Apenas Bordas Externas No Campo Das Informacoes E Depois De Concluido Imprimir O Documento."
    
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Rel.Range("A1:A" & i), Rel.Range("A" & i).Text) > 1 Then
            Rel.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Rel.Range("A" & i).EntireRow.Delete
        End If
    Next i

Set wb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculate = True

End Sub

Você tem que criar mais uma aba com o nome de "duplicado" (onde vai ser inserido os valores duplicados).

Qualquer coisa da o grito.
Abraço

Bom dia Bernardo

Tentei rodar essa macro na minha planilha mas aparece o seguinte erro:

Erro de compilação:

Era esperado Function ou variavel

e fica amarelo o nome da rotina e sublinhado de o campo .Calculate

Tentei mudar algumas coisas mas não surtiu efeito.

Desde já agradeço a força caro colega.

Abraços.

Bom dia Fabiosp,

Realmente digitei errado ali... Deixa assim:

Option Explicit
Sub colar()
Dim i       As Long
Dim UltLDad As Long
Dim UltLDup As Long
Dim wb      As Workbook
Dim Dad     As Worksheets
Dim Rel     As Worksheets
Dim Dup     As Worksheets

Set wb = ThisWorkbook
Set Dad = wb.Sheets("dados")
Set Rel = wb.Sheets("relatorio")
Set Dup = wb.Sheets("duplicado")

UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual

    Dad.Range("M17:Q42").Copy
    Rel.Range("A2").PasteSpecial Paste:=xlPasteValues
    MsgBox "Apos Gerar O Relatorio Utilzar Apenas Bordas Externas No Campo Das Informacoes E Depois De Concluido Imprimir O Documento."
    
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Rel.Range("A1:A" & i), Rel.Range("A" & i).Text) > 1 Then
            Rel.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Rel.Range("A" & i).EntireRow.Delete
        End If
    Next i

Set wb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Qualquer coisa da o grito.
Abraço

Prezado colega Bernardo

Muito obrigado pela ajuda.

Agora esta aparecendo outro erro

Erro em tempo de execução 13

Tipos incompativeis

Clicando em depurar este campo fica amarelo Set Dad = wb.Sheets("dados")
Alterei algumas coisas mas não surtiu efeito.

Desculpa pelo incomodo.

Abraços.

Cara, deixa assim:

Option Explicit
Sub colar()
Dim i       As Long
Dim UltLDad As Long
Dim UltLDup As Long
Dim wb      As Workbook
Dim Dad     As Worksheet
Dim Rel     As Worksheet
Dim Dup     As Worksheet

Set wb = ThisWorkbook
Set Dad = wb.Sheets("dados")
Set Rel = wb.Sheets("relatorio")
Set Dup = wb.Sheets("duplicado")

UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual

    Dad.Range("M17:Q42").Copy
    Rel.Range("A2").PasteSpecial Paste:=xlPasteValues
    MsgBox "Apos Gerar O Relatorio Utilzar Apenas Bordas Externas No Campo Das Informacoes E Depois De Concluido Imprimir O Documento."
    
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Rel.Range("A1:A" & i), Rel.Range("A" & i).Text) > 1 Then
            Rel.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Rel.Range("A" & i).EntireRow.Delete
        End If
    Next i

Set wb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Sem a planilha fica difícil testar.

Qualquer coisa da o grito.
Abraço

Prezado Bernardo

Desculpa o incomodo foi mal.
Realmente sem a planilha fica difícil saber se funciona, desculpe minha falha.
Agora testei e deu certo.

Muito obrigado pela ajuda e por ser tão generoso.

Abraços.