Copiar por critério de várias planilhas e colar em uma só planilha.

Question

Olá amigos!

Tenho três planilhas (FilmesEmHD1; FilmesEmHD2; FilmesEmHD3) onde tentei utilizar uma fórmula copiada da internet para copiar dessas planihas e colar dados por critério em outra planilha (ControleGeralFilmes). Acontece que, ao copiar os dados e colar em outra planilha ela não cola, apesar de um msg box afirmar que "os dados foram copiados". Já tentei descobrir onde estou errando, mas não consegui.

O que eu tentei fazer:

1º- Todas as planilhas tem os mesmos cabeçalhos.

2º- Copiar os dados célula B2:C5000, se for igual a um critério na Celula G1 da Plan ControleGeralFilmes

3º- Colar os dados copiados na plan ControleGeralFilmes, nas células B2:C5000, linha após linha, sem apagar o que já tinha sido copiado antes.

4º- Apagar, nas planilhas origem das cópias, os dados que foram copiados mas não excluir o cabeçalho.

5º- Informar que os dados foram copiados com sucesso.

Obs: Na fórmula que tentei adaptar, só havia a possibilidade de copiar de uma só planilha, como faço para copiar dados das três planilhas por critério?

Vocês poderiam me ajudar?

Segue a planilha:

https://www.sendspace.com/file/0yll1d

Grato.

Answer 1

Boa noite Undemberg,

Para sua solicitação achei melhor criar um código do zero... Segue abaixo:

Sub Obter_Dados()
    Application.ScreenUpdating = False
        On Error GoTo Err_Execute
            Plan_Inicial = Plan2.Name 'Obtém o nome da planilha inicial
            Criterio = Sheets(Plan_Inicial).Range("G1").Text 'Obtém o nome do Critério
            'Range("A2:C3000").ClearContents 'Apaga todos os dados da planilha inicial
            For Each ws In ThisWorkbook.Worksheets 'Percorre todas as sheets da pasta de trabalho atual
                ws.Select 'Seleciona primeira sheet
                Plan_Verificar = ws.Name 'Obtém o nome da Sheet
                If Plan_Verificar <> Plan_Inicial Then 'Verifica se a planilha atual é diferente do consolidado
                    vLinha = 2 'Obtém o numero da primeira linha
                    Do While Range("C" & vLinha).Value <> "" 'Percorre todas as linhas da sheet atual enquanto for dirente de vazio
                        Criterio_Verificar = Range("C" & vLinha) 'Obtém o nome do critério nas sheets
                        If Criterio = Criterio_Verificar Then 'Verifica se o critério é igual ao selecionado
                            Rows(vLinha & ":" & vLinha).Copy 'Copia a linha
                            Sheets(Plan_Inicial).Select 'Seleciona a planilha inicial
                            Range("B30000").Select
                            Selection.End(xlUp).Select
                            vLinha_Final = ActiveCell.Row + 1 'Obtém o númedo da ultima linha preenchida
                            Rows(vLinha_Final & ":" & vLinha_Final).Select 'Seleciona a linha depois da linha preenchida
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'Cola valores
                            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Cola formatos
                            ws.Select 'Seleciona a planilha novamente
                        End If
                    vLinha = vLinha + 1
                    Loop
                    'LOOP PARA EXCLUSÃO DAS LINHAS
                    lLast = ws.UsedRange.Rows.Count
                    For vLinhaExclusao = lLast To 2 Step -1
                        Criterio_Verificar = Range("C" & vLinhaExclusao) 'Obtém o nome do critério nas sheets
                        If Criterio = Criterio_Verificar Then 'Verifica se o critério é igual ao selecionado
                            Rows(vLinhaExclusao).Delete Shift:=xlUp 'Exclui a linha selecionada
                        End If
                    Next
                End If
            Next
            Sheets(Plan_Inicial).Select
            Range("G1").Select
            MsgBox "Todos os dados procurados em '" & Criterio & "' foram copiados ."
        Exit Sub
    Application.ScreenUpdating = True
    
Err_Execute:
MsgBox "ocorreu um erro.", vbInformation, "Desculpe o Transtorno."
End Sub

Caso queira fazer download da planilha com o código segue o link abaixo:

Filme que eu tenho.xls

Espero ter ajudado!

Roberto Santos

Answer 2

Olá Roberto Santos, Boa noite!

Muito obrigado. A planilha ficou excepcional.

Sua ajuda foi excepcional. Seria muito bom se houvesse mais pessoas aptas a ajudar como vc.

Tenho feito muitas planilhas, sozinho, sem ajuda, sem curso, na marra, na garra! Mas essa que enviei, não consegui de jeito nenhum.

Obs: Não cosegui entrar para dar a nota pelo seu trabalho (deu erro de servidor) vou tentar mais tarde. De antemão, de 0 a 10, sua ajuda, conhecimento, dedicação e rapidez, foi 12!!! Isso mesmo, 12!

Grato. 

Undemberg.

Answer 3

Disponha meu caro, 

Hoje faço questão de ajudar, pois pelo caminho encontrei muitas pessoas que também me ajudaram.

Me mande seu e-mail que eu lhe envio um material para estudo.

Tenho umas video-aulas com apostila completíssima, excelente para quem deseja se aprofundar em VBA.

Um abraço!

---

Roberto Santos

Answer 4

[e-mail]