Talvez assim:
Sub transfere()
'Declaração de variaveis
Dim lRow As Long, lastRow As Long, lR As Long
'Determina a ultima linha preenchida - altere o nome planilha para a sua
lastRow = Sheets("Cartao").Cells(Cells.Rows.Count, "A").End(xlUp).Row
'seleciona a planilha - Altere para o nome de sua planilha
Sheets("Cartao").Select
'Inicia o laço à partir da linha 10 até a ultima
For lR = 11 To lastRow
'determina qual a ultima linha preenchida na planilha que ira receber os dados
lRow = Sheets("Backup").Cells(Cells.Rows.Count, "A").End(xlUp).Row
'Verifica se atende a condição preestabelecida
If Cells(lR, "T").Value = "Sim" Then
'If Cells(lR, 19).Value = "Sim" Then
'Se atende seleciona a range de A:S e copia para o backup sem formulas
Range("A" & lR & ":T" & lR).Select
Selection.Copy
Sheets("Backup").Select
Range("A" & lRow + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Limpa o valor na planilha origem
Sheets("Cartao").Select
Range("A" & lR & ":G" & lR).ClearContents
End If
Next
'Ordena a planilha de origem para "eliminar" as linhas em branco
Sheets("Cartao").Select
Range("A11:S100").Select
Selection.Sort Key1:=Range("H11"), Order1:=xlAscending, Key2:=Range( _
"B11"), Order2:=xlAscending, Key3:=Range("D11"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
'Ordena a planilha de backup
Sheets("Backup").Select
Range("A7:S1000").Select
Selection.Sort Key1:=Range("H7"), Order1:=xlAscending, Key2:=Range("B7") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Range("D6").Select
Sheets("Cartao").Select
Range("h1").Select
End Sub
Postado : 18/06/2015 6:39 am