Bom dia Fabiosp,

Bom, sem a planilha fica um pouco difícil testar, ainda mais com dois códigos distintos. Mas testa esse código.

Option Explicit
Sub colar()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet
Dim GRel                As Worksheet


Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("dados")
Set Rel = Twb.Sheets("relatorio")
Set Dup = Twb.Sheets("duplicado")
Set GRel = Sheets("RELATORIO GERAL")


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


Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = 2 To UltimaLinhaRelat
            If Trim(Range("K" & j).Value) = "verificado" Then
                GRel.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).Copy
                Gwb.ActiveSheet.Range("A" & j & ":K" & j).PasteSpecial Paste:=xlPasteValues
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next
    Sheets("JAN-13").Select
    
    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 Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Me fala a linha que etá aparecendo o erro.
Ou me manda a planilha com a adaptação para ir testando.

Qualquer coisa da o grito.
Abraço

Mestre Bernardo Bom dia

Muito obrigado pela ajuda!

segue a planilha

Bom, sem a planilha fica um pouco difícil testar, ainda mais com dois códigos distintos. Mas testa esse código.

Option Explicit
Sub colar()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet
Dim GRel                As Worksheet


Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("dados")
Set Rel = Twb.Sheets("relatorio")
Set Dup = Twb.Sheets("duplicado")
Set GRel = Sheets("RELATORIO GERAL")


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


Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = 2 To UltimaLinhaRelat
            If Trim(Range("K" & j).Value) = "verificado" Then
                GRel.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).Copy
                Gwb.ActiveSheet.Range("A" & j & ":K" & j).PasteSpecial Paste:=xlPasteValues
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next
    Sheets("JAN-13").Select
    
    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 Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Me fala a linha que etá aparecendo o erro.
Ou me manda a planilha com a adaptação para ir testando.

Qualquer coisa da o grito.
Abraço

Cara, as planilhas usadas no código que eu fiz são as mesmas usadas no código que o Wagner fez?

Está faltando Sheets entre os workbooks nas planilhas que me enviou. Não irá funcionar assim.

Olá Bernardo

As planilhas são as mesmas só inclui algumas plan pra testar a rotina do mestre Wagner Morel.
Esta faltando algumas plan?
Acho que como andei mexendo devo ter apagado algo.
Mas que necessito é copiar toda linha que consta a informação "verificado" da planilha relatório para a planilha relatório geral depois eliminar a duplicidade e colar pra outra plan
Voce havia me ajudado a criar essa parte de eliminar a duplicidade e copiar pra outra plan, porém necessito fazer mesma coisa na planilha onde tenho a rotina criada pelo meste Wagner Morel.

Desde já agradeço a ajuda e desculpe o incomodo caro colega.
Abraços.

Cara, agora me confundiu tudo...

Não sei se entendi ou fiz certo, mas tenta essa:

Option Explicit
Sub Copiardados()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet
Dim GRel                As Worksheet


Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("RELATORIO GERAL")
Set Dup = Twb.Sheets("DUPLICADO")
Set GRel = Sheets("RELATORIO GERAL")

UltimaLinhaGeral = Dad.Cells(Cells.Rows.Count, 11).End(xlUp).Row + 1
UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual


Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = UltimaLinhaRelat To 2 Step -1
            If Trim(Range("K" & j).Value) = "verificado" Then
                ActiveSheet.Range("A" & j & ":K" & j).Copy
                GRel.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).PasteSpecial Paste:=xlPasteValues
                Range("A" & j).EntireRow.Delete
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next
    Sheets("JAN-13").Select
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Dad.Range("A1:A" & i), Dad.Range("A" & i).Text) > 1 Then
            Dad.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Dad.Range("A" & i).EntireRow.Delete
            UltLDup = UltLDup + 1
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Tem que criar a planilha com o nome de "DUPLICADO" na pasta de trabalho "RELATORIO GERAL".

Qualquer coisa da o grito.
Abraço

Boa Noite mestre Bernardo

Vou testar depois na minha planilha pois agora estou em casa e aqui não tenho Excel ...
Por enquanto só tenho a agradecer pela sua generosidade.

Abraços caro colega.

Caro colega Bernardo bom dia.

Testei a rotina na minha planilha mas não funciona.
Tentei fazer alguns ajustes mas com meu pouco conhecimento em VBA não consegui resolver.
Vou anexar a planilha para ser analisada.

Desde já agradeço a ajuda e desculpa o incomodo.

Abraços.

Bom dia Fabiosp,

Na planilha "RELATORIO" que enviou não tem informações com "Verificado", alterei um valor aqui para verificado e fiz o teste e funcionou normalmente. Usa esse:

Sub Copiardados_by_Bernardo()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet

Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("RELATORIO GERAL")
Set Dup = Twb.Sheets("DUPLICADO")

UltimaLinhaGeral = Dad.Cells(Cells.Rows.Count, 11).End(xlUp).Row + 1
UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual

Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = UltimaLinhaRelat To 2 Step -1
            If UCase(Trim(Range("K" & j).Value)) = "VERIFICADO" Then
                ActiveSheet.Range("A" & j & ":K" & j).Copy
                Dad.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).PasteSpecial Paste:=xlPasteValues
                Range("A" & j).EntireRow.Delete
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next

    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Dad.Range("A1:A" & i), Dad.Range("A" & i).Text) > 1 Then
            Dad.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Dad.Range("A" & i).EntireRow.Delete
            UltLDup = UltLDup + 1
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Dados Copiados com Sucesso!", vbDefaultButton1, "CoPIA DE DADOS"

End Sub

Qualquer coisa da o grito.
Abraço

Caro colega Bernardo,

Agora esta funcionando valeu!!
Apenas um detalhe.
Percebi que essa rotina apaga a informação da planilha original e cola na outra, não é?
Apenas por curiosidade tem como fazer apenas copiar sem apagar a original?

Abraços

Bom dia Fabiosp,

Então era isso mesmo... hahahahha

Sub Copiardados_by_Bernardo()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet

Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("RELATORIO GERAL")
Set Dup = Twb.Sheets("DUPLICADO")

UltimaLinhaGeral = Dad.Cells(Cells.Rows.Count, 11).End(xlUp).Row + 1
UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual

Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = UltimaLinhaRelat To 2 Step -1
            If UCase(Trim(Range("K" & j).Value)) = "VERIFICADO" Then
                ActiveSheet.Range("A" & j & ":K" & j).Copy
                Dad.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).PasteSpecial Paste:=xlPasteValues
                'Range("A" & j).EntireRow.Delete
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next

    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Dad.Range("A1:A" & i), Dad.Range("A" & i).Text) > 1 Then
            Dad.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Dad.Range("A" & i).EntireRow.Delete
            UltLDup = UltLDup + 1
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Dados Copiados com Sucesso!", vbDefaultButton1, "CoPIA DE DADOS"

End Sub

Qualquer coisa da o grito.
Abraço

Mestre Bernardo
Era isso mesmo hahaha!!
Agora ficou perfeito !!
Valeu a ajuda mestre.
Desculpe o incomodo.

Abraços.

Tranquilo
Qualquer coisa da o grito que a gente dá um jeito.
Abraço

Valeu pela força mestre!!

Abraços