Este fórum está sendo desativado

[kalebe]

Senhores, bom dia. Sei que já existe um tópico ainda em aberto sobre o mesmo assunto, porém peço ajuda aos senhores para que possa ser sanado a minha duvida do segundo quesito abaixo, pois o primeiro já esta resolvido

QUESITOS:
1º) Transportar para Plan2 somente as informações que tem como critério a palavra "Sim" na Col E ( RESOLVIDO )
2º) Ao transportar as informações para a Plan2 deverá apagar da Plan1 as linhas que tiver como critério a palavra "Sim" na Col E, não devendo existir linhas em branco após apagadas entre os assuntos


Estou usando esse código abaixo:

Código: Selecionar todos

Sub relatorio()
    Application.ScreenUpdating = False
    Plan2.Range("A2:E50000").ClearContents
    ultimaLinha = Plan1.Cells(Rows.Count, "a").End(xlUp).Row
    lin = 1
    For i = 1 To ultimaLinha
        If Plan1.Cells(i, 5) <> "" Then
            Plan2.Cells(lin, 1) = Plan1.Cells(i, 1)
            Plan2.Cells(lin, 2) = Plan1.Cells(i, 2)
            Plan2.Cells(lin, 3) = Plan1.Cells(i, 3)
            Plan2.Cells(lin, 4) = Plan1.Cells(i, 4)
            Plan2.Cells(lin, 5) = Plan1.Cells(i, 5)
            lin = lin + 1
        End If
    Next
    Application.ScreenUpdating = True

End Sub

Segue o Arquivo em Anexo.

[Parkeless]

Olá Kalebe, tudo bem?

O código anterior apagava os dados anteriores da Plan2; fiz algumas alterações para evitar perda de dados.

Agora ele faz o seguinte:
1. Passa os dados para a Plan2 sem apagar os dados anteriores, iniciando a inserção a partir da primeira célula em branco na coluna A
2. Deleta os dados que foram transferidos na Plan1.

Código: Selecionar todos

Sub relatorio()
    Application.ScreenUpdating = False
    'Plan2.Range("A2:E50000").ClearContents
    ultimalinha = Plan1.Cells(Rows.Count, "a").End(xlUp).Row
    lin = 1
    'For i = 1 To ultimaLinha
    For i = 2 To ultimalinha
        'If Plan1.Cells(i, 5) <> "" Then
        If Plan1.Cells(i, 5) = "Sim" Then
            lin = Sheets("Plan2").Range("A1000000").End(xlUp).Row + 1
            Plan2.Cells(lin, 1) = Plan1.Cells(i, 1)
            Plan2.Cells(lin, 2) = Plan1.Cells(i, 2)
            Plan2.Cells(lin, 3) = Plan1.Cells(i, 3)
            Plan2.Cells(lin, 4) = Plan1.Cells(i, 4)
            Plan2.Cells(lin, 5) = Plan1.Cells(i, 5)

            'lin = lin + 1
        End If
    Next
    
    'Apagar linhas
    For i = ultimalinha To 2 Step -1
        If Plan1.Cells(i, 5) = "Sim" Then
            Plan1.Rows(i & ":" & i).Delete
        End If
    Next
    
    
    Application.ScreenUpdating = True

End Sub