none
Macro para copiar um intervalo de uma planilha de varios arquivos para outra pasta de trabalho na próxima linha livre RRS feed

  • Pergunta

  • Tenho varios arquvivos dentro de uma pasta que contém uma planilha com cabeçalho (em colunas) padrão, porém o intervalo de linhas é dinâmico. Quero copiar todos os dados (a partir de uma linha especifica), para uma planilha em outra pasta de trabalho ativa. Porém estou com o seguinte código que apresenta o erro "Subscrito fora do Intervalo", alguém poderia me ajudar?

    Sub ImportarArquivosExcel()
        Dim Pasta As String
        Dim Arquivo As String
        
        'Abre uma caixa de diálogo para selecionar a pasta
        'onde estão os arquivos
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Coloca na variável o nome do primeiro arquivo
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
        'Inicia um laço para cópia dos arquivos
        Do
            'Abre o arquivo
            Workbooks.Open Pasta & "\" & Arquivo
            
            'Copia o intervalo usado da planilha de origem e cola
            'na primeira linha vazia da planilha de destino
            ActiveSheet.UsedRange.Copy _
            ThisWorkbook.Sheets("Plan1").Range("A" & Cells.Rows.Count).End(xlUp).Offset(1, 0)
            
            'Fecha o arquivo
            Workbooks(Arquivo).Close
            
            'Coloca na variável o nome do próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
    End Sub



    • Editado Tomadon quarta-feira, 18 de setembro de 2013 12:30
    terça-feira, 17 de setembro de 2013 17:58

Respostas

  • Olá, consegui executar modificando as intruções como segue abaixo. Porém há uma nova necessidade: Agora preciso que em cada linha na próxima coluna livre venha o nome do arquivo de origem utilizando este mesmo código, se possível utilizando caracteres especificos ou no mínimo retirando a extenção do arquivo. Com esta implentação no código teriamos diversas aplicações.

    Sub Consolidar()
        Dim Pasta As String
        Dim Arquivo As String
        
        'Seleciona a pasta do Windows onde estão todas as
        'pastas de trabalho a serem copiadas
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Armazena o nome do primeiro arquivo (pasta de trabalho) na variável "Arquivo"
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
        'Laço para para percorrer todos os arquivos da pasta do windows
        Do
            
            'Abre o arquivo
            Workbooks.Open (Pasta & "\" & Arquivo)
            
            'Copia a região adjacente à celula A3 para a planilha de consolidação
            [A3].CurrentRegion.Copy ThisWorkbook.ActiveSheet.Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1, 0)
            
            'Fecha o arquivo
            Workbooks(Arquivo).Close False
                    
            'Lista o próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
        
    End Sub
    

    Att,

    Cristiano Tomadon

    • Marcado como Resposta Tomadon quarta-feira, 18 de setembro de 2013 11:47
    quarta-feira, 18 de setembro de 2013 11:47

Todas as Respostas

  • Olá, consegui executar modificando as intruções como segue abaixo. Porém há uma nova necessidade: Agora preciso que em cada linha na próxima coluna livre venha o nome do arquivo de origem utilizando este mesmo código, se possível utilizando caracteres especificos ou no mínimo retirando a extenção do arquivo. Com esta implentação no código teriamos diversas aplicações.

    Sub Consolidar()
        Dim Pasta As String
        Dim Arquivo As String
        
        'Seleciona a pasta do Windows onde estão todas as
        'pastas de trabalho a serem copiadas
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            Pasta = .SelectedItems(1)
        End With
        
        'Armazena o nome do primeiro arquivo (pasta de trabalho) na variável "Arquivo"
        Arquivo = Dir(Pasta & "\" & "*.xls*")
        
        'Laço para para percorrer todos os arquivos da pasta do windows
        Do
            
            'Abre o arquivo
            Workbooks.Open (Pasta & "\" & Arquivo)
            
            'Copia a região adjacente à celula A3 para a planilha de consolidação
            [A3].CurrentRegion.Copy ThisWorkbook.ActiveSheet.Cells(Cells.Rows.Count, "A").End(xlUp).Offset(1, 0)
            
            'Fecha o arquivo
            Workbooks(Arquivo).Close False
                    
            'Lista o próximo arquivo
            Arquivo = Dir
        Loop While Arquivo <> ""
        
        Application.CutCopyMode = False
        
        MsgBox "Fim de Execução da Macro"
        
    End Sub
    

    Att,

    Cristiano Tomadon

    • Marcado como Resposta Tomadon quarta-feira, 18 de setembro de 2013 11:47
    quarta-feira, 18 de setembro de 2013 11:47
  • Cristiano,

    A macro funcionou apenas uma única vez. Tentei fazer funcionar de várias maneiras e nada, renomeei as planilhas arquivos e nada.

    Sabe dizer o que aconteceu?

    Att,

    Marcio

    terça-feira, 11 de fevereiro de 2014 04:24
  • Olá Marcio,

    Aqui sempre funcionou, vc utilizou o código igual a este, ou fez alguma modificação?

    Se sim como ele ficou? O Que vc deseja exatamente fazer?

    Att,


    Cristiano Tomadon

    terça-feira, 11 de fevereiro de 2014 14:00
  • Olá,

    Como aproveitar esta macro colando para a planilha de consolidação apenas os valores (Paste  special) das células e não as fórmulas. Ao invés de considerar a região adjacente, gostaria de copiar apenas uma linha , por exemplo as células a direita da AM6.

    Grato

    quarta-feira, 10 de junho de 2015 18:35