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

  • Pergunta

  • 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.

    terça-feira, 14 de outubro de 2014 17:04

Respostas

  • 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

    terça-feira, 14 de outubro de 2014 21:17

Todas as Respostas

  • 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

    terça-feira, 14 de outubro de 2014 21:17
  • 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.

    quarta-feira, 15 de outubro de 2014 02:11
  • 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

    quarta-feira, 15 de outubro de 2014 11:48
  • cedrosolucoesambientais@gmail.com
    quarta-feira, 23 de maio de 2018 12:53