MACRO - abrir arquivos .xls e extrair dados

[danyelmonteyro]

Bom dia a todos. Pessoal, andei procurando nos tópicos do forum e não encontrei nada, por isso abri este tópico e se dei mancada, me desculpem. Eu sou meio cru em VBA e Macros mas a minha dúvida é a seguinte. Eu tenho um arquivo no Excel que necessito constantemente atualizar os dados contidos em uma das planilhas (BD). Acontece que para atualizar tal planilha, eu preciso de abrir vários arquivos .xls que são gerados por outro programa e copiar dados específicos deste arquivo e cola-los na " planilha mestre". Eu já consegui fazer tal atualização, informando o nome do arquivo que devo abrir, mas eu preciso que seja mais automatizado. Gostaria que uma macro percorresse todo o diretório e automaticamente fizesse tal operação. Se puderem me ajudar, será uma SENHORA mão na roda.

Grande abraço a todos.

Qualquer dúvida, estou por aqui.

[webmaster]

Danyel,

Se juntar as peças com esta macro:

http://www.tomasvasquez.com.br/blog/mic ... -diretorio

Creio que vai conseguir o que quer. Faço o teste e avise se deu certo.

Abraços

[danyelmonteyro]

Boa tarde Tomás.

A macro que você postou, realiza a listagem dos arquivos de um diretório correto? Agradeço demais pois com este procedimento dei umamelhorada na minha planilha mas não é ainda o que eu estou precisando.

Tipo...

Eu preciso que tal macro, abra arquivo por arquivo, copie algumas celulas contidas neste arquivo, feche-o, cole tais células no arquivo mestre e assim continue fazendo até abrir todos os arquivos .xls do meu diretório, transferindo todos os dados para este arquivo mestre.

Desde já, agradeço a ajuda pois fui em vários outros fóruns e ninguém me respondeu.

Adorei o forum... está de parabéns.

Abraços.

[JValq]

Boa tarde,

Veja se este código de exemplo te ajuda:

Código: Selecionar todos

Sub ImportarDados()
    Dim fs, f, f1, fc
    Dim Pasta As String
    Dim Coluna As Integer
    
    'Abre uma caixa de diálogo para possibilitar a seleção de uma pasta
    Application.FileDialog(msoFileDialogFolderPicker).Show
    Pasta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Pasta)
    Set fc = f.Files
    'Variável para controlar a coluna na qual será efetuada a cópia
    Coluna = 1
    For Each f1 In fc
        'Verifica a extensão do arquivo
        If Right(f1.Name, 3) = "xls" Then
            'Abre o arquivo Excel
            Workbooks.Open f1.Name
            'Seleciona a Plan1
            Sheets("Plan1").Select
            'Faz a cópia
            ActiveSheet.Range("A1:A10").Copy ThisWorkbook.Sheets("Plan1").Cells(1, Coluna)
            'incrementa o número da coluna
            Coluna = Coluna + 1
            'Fecha o arquivo Excel
            Workbooks(f1.Name).Close SaveChanges:=False
        End If
    Next
End Sub

Caso seja isso, é só adaptar para a sua necessidade.

Abraço

[danyelmonteyro]

Bom dia pessoal.

JValq, era praticamente o que eu precisava. Realizei algumas adaptações e funcionou perfeitamente.

Vocês são feras. Muito obrigado pela ajuda.

[guilherme_pontes]

Amigos,

Estou utilizando este código até a parte que ele abre o arquivo.

Tinha conseguido fazê-lo funcionar mas na segunda vez que eu tentei rodar quando ele vai abrir o arquivo da pasta aparece erro dizendo que não encontrou o arquivo mas todos os parâmetros e caminhos (olhando as variáveis locais) estão corretos, alguém pode me dar uma ajuda??

abs

[williandourado]

Boa tarde,

Veja se este código de exemplo te ajuda:

► Show Spoiler

Código: Selecionar todos

Sub ImportarDados()
    Dim fs, f, f1, fc
    Dim Pasta As String
    Dim Coluna As Integer
    
    'Abre uma caixa de diálogo para possibilitar a seleção de uma pasta
    Application.FileDialog(msoFileDialogFolderPicker).Show
    Pasta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Pasta)
    Set fc = f.Files
    'Variável para controlar a coluna na qual será efetuada a cópia
    Coluna = 1
    For Each f1 In fc
        'Verifica a extensão do arquivo
        If Right(f1.Name, 3) = "xls" Then
            'Abre o arquivo Excel
            Workbooks.Open f1.Name
            'Seleciona a Plan1
            Sheets("Plan1").Select
            'Faz a cópia
            ActiveSheet.Range("A1:A10").Copy ThisWorkbook.Sheets("Plan1").Cells(1, Coluna)
            'incrementa o número da coluna
            Coluna = Coluna + 1
            'Fecha o arquivo Excel
            Workbooks(f1.Name).Close SaveChanges:=False
        End If
    Next
End Sub

Caso seja isso, é só adaptar para a sua necessidade.

Abraço

Bom dia JValq!
Segue o código alterado:

Código: Selecionar todos

Sub ImportarDados()
    Dim fs, f, f1, fc
    Dim Pasta As String
    Dim Coluna As Integer
    
    'Abre uma caixa de diálogo para possibilitar a seleção de uma pasta
    Application.FileDialog(msoFileDialogFolderPicker).Show
    Pasta = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Pasta)
    Set fc = f.Files
    'Variável para controlar a coluna na qual será efetuada a cópia
    Linha = 2
    For Each f1 In fc
        'Verifica a extensão do arquivo
        If Right(f1.Name, 4) = "xlsm" Then
            'Abre o arquivo Excel
            Workbooks.Open f1.Name, ReadOnly:=False, Notify:=False, IgnoreReadOnlyRecommended:=True
            'Seleciona a ENGENHARIA
            Sheets("ENGENHARIA").Select
            'Faz a cópia
            ActiveSheet.Range("B6").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 1)
            ActiveSheet.Range("B18").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 2)
            ActiveSheet.Range("B19").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 3)
            ActiveSheet.Range("B20").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 4)
            ActiveSheet.Range("B21").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 5)
            ActiveSheet.Range("B22").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 6)
            ActiveSheet.Range("B23").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 7)
            ActiveSheet.Range("B24").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 8)
            ActiveSheet.Range("B26").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 9)
            ActiveSheet.Range("E75").Copy ThisWorkbook.Sheets("ENGENHARIA").Cells(Linha, 10)
            'incrementa o número da coluna
            Linha = Linha + 1
            'Fecha o arquivo Excel
            Workbooks(f1.Name).Close SaveChanges:=False
        End If
    Next f1
End Sub

Usei esse código mas estou com alguns bugs.
1º - Estou com um erro quando coloco mais de um arquivo na pasta, aparece o seguinte erro:
Erro em tempo de execução '1004':
Não foi possível encontrar PLANILHA.xlsm. É possível que tenha sido movido, renomeado ou excluído?
2º - Dá o mesmo erro citado acima se eu renomear o arquivo ou copiar e colar ele na mesma pasta.
3º - Se eu conseguir importar os dados que quero, alterar na planilha fonte e executar novamente o macro, os dados não atualizam.
4º - Se a célula fonte conter uma fórmula, dá um erro #REF, queria copiar apenas o valor dessa célula.

Pode me ajudar? Minha chefe pediu um jeito de eu fazer isso no excel e esse código foi o mais próximo do que preciso.