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

Question

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

Answer 1

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

Answer 2

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

Answer 3

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

Answer 4

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