Note: The other languages of the website are Google-translated. Back to English

Como percorrer arquivos em um diretório e copiar dados em uma planilha mestre no Excel?

Supondo que haja várias pastas de trabalho do Excel em uma pasta e você queira percorrer todos esses arquivos do Excel e copiar dados de um intervalo especificado de planilhas com o mesmo nome em uma planilha mestre do Excel, o que pode fazer? Este artigo apresenta um método para alcançá-lo em detalhes.

Percorra os arquivos em um diretório e copie os dados em uma planilha mestre com código VBA


Percorra os arquivos em um diretório e copie os dados em uma planilha mestre com código VBA

Se você deseja copiar os dados especificados no intervalo A1: D4 de todas as planilhas 1 das pastas de trabalho em uma determinada pasta para uma planilha mestre, faça o seguinte.

1. Na pasta de trabalho, você criará uma planilha mestre, pressione o botão outro + F11 chaves para abrir o Microsoft Visual Basic para Aplicações janela.

2. No Microsoft Visual Basic para Aplicações janela, clique em inserção > Módulo. Em seguida, copie o código VBA abaixo para a janela de código.

Código VBA: percorre arquivos em uma pasta e copia os dados em uma planilha mestre

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Nota:

1). No código, “A1: D4"E"Sheet1”Significa que os dados no intervalo A1: D4 de toda a Planilha1 serão copiados para a planilha mestre. E “Nova Folha”É o nome da nova planilha mestre criada.
2). Os arquivos do Excel na pasta específica não devem abrir.

3. aperte o F5 chave para executar o código.

4. Na abertura Procurar janela, selecione a pasta que contém os arquivos que você percorrerá e clique no botão OK botão. Veja a imagem:

Em seguida, uma planilha mestre chamada “Nova Planilha” é criada no final da pasta de trabalho atual. E os dados no intervalo A1: D4 de todas as Planilhas1 na pasta selecionada são listados dentro da planilha.


Artigos relacionados:


As melhores ferramentas de produtividade para escritório

O Kutools for Excel resolve a maioria dos seus problemas e aumenta sua produtividade em 80%

  • armadilha para peixes: Insira rapidamente fórmulas complexas, gráficos e qualquer coisa que você tenha usado antes; Criptografar células com senha; Criar lista de discussão e enviar emails ...
  • Barra Super Fórmula (edite facilmente várias linhas de texto e fórmula); Layout de leitura (ler e editar facilmente um grande número de células); Colar na faixa filtrada...
  • Mesclar células / linhas / colunas sem perder dados; Dividir o conteúdo das células; Combinar linhas / colunas duplicadas... Evite células duplicadas; Comparar intervalos...
  • Selecione Duplicado ou Único Linhas; Selecione linhas em branco (todas as células estão vazias); Super Find e Fuzzy Find em muitos livros; Seleção aleatória ...
  • Cópia exata Várias células sem alterar a referência da fórmula; Criação automática de referências para várias folhas; Inserir marcadores, Caixas de seleção e mais ...
  • Extrair Texto, Adicionar texto, remover por posição, Remover Espaço; Criar e imprimir subtotais de paginação; Converter entre conteúdo de células e comentários...
  • Super Filtro (salvar e aplicar esquemas de filtro a outras planilhas); Classificação Avançada por mês / semana / dia, frequência e mais; Filtro Especial por negrito, itálico ...
  • Combine pastas de trabalho e planilhas; Mesclar tabelas com base em colunas-chave; Divida os dados em várias folhas; Conversão em lote de xls, xlsx e PDF...
  • Mais de 300 recursos poderosos. Suporta Office / Excel 2007-2021 e 365. Suporta todos os idiomas. Fácil implantação em sua empresa ou organização. Recursos completos de avaliação gratuita de 30 dias. Garantia de devolução do dinheiro em 60 dias.
guia kte 201905

Guia do Office traz interface com guias para o Office e torna seu trabalho muito mais fácil

  • Habilite a edição e leitura com guias em Word, Excel, PowerPoint, Publisher, Access, Visio e Project.
  • Abra e crie vários documentos em novas guias da mesma janela, em vez de em novas janelas.
  • Aumenta sua produtividade em 50% e reduz centenas de cliques do mouse para você todos os dias!
parte inferior da aba do escritório
Comentários (20)
Ainda não há classificações. Seja o primeiro a avaliar!
Este comentário foi feito pelo moderador no site
obrigado pelo código vba! Funciona perfeitamente! Gostaria de saber qual é o código se eu precisar COLAR AS VALUE em vez disso? Thx com antecedência!
Este comentário foi feito pelo moderador no site
Olá LaiLing,
O código a seguir pode ajudá-lo a resolver o problema. Obrigado pelo seu comentário.

Submerge2MultiSheets()
Dim xRg como intervalo
Dim xSelItem como variante
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr como string
Escurecer xBook, xWorkBook como pasta de trabalho
Escurecer xSheet como planilha
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Sheet1"
xRgStr = "A1:D4"
Definir xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Com xFileDlg
Se .Mostrar = -1 Então
xSelItem = .SelectedItems.Item(1)
Definir xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("New Sheet")
Se o xSheet não for nada, então
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "New Sheet"
Set xSheet = xWorkBook.Sheets("New Sheet")
Se acabar
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Se xFileName = "" Então Exit Sub
Faça até xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Definir xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir ()
xBook. Fechar
laço
Se acabar
Terminar com
Definir xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Verdadeiro
xRg.UseStandardWidth = Verdadeiro
Application.DisplayAlerts = Verdadeiro
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Este comentário foi feito pelo moderador no site
Olá, obrigado pelo código. Por favor, você pode me informar como posso incluir o nome do arquivo Excel do qual o intervalo de dados foi copiado? Isso seria uma grande ajuda!

Obrigado.
Este comentário foi feito pelo moderador no site
Olá,

Obrigado pelo tutorial.

Como eu faria: Copiar apenas a linha em "Planilha1" com valores da linha "total" e colar com [nome do arquivo] na planilha mestra chamada "Nova planilha". Observar a linha com Total pode ser diferente em cada planilha.

Por exemplo:
Arquivo1: Planilha1
Col1, Col2, Colx
1,2,15
Resultado, 10,50

Arquivo2: Planilha1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Resultado, 300,500

MasterFile: "Nova planilha":
arquivo 1, 10, 50
arquivo 2, 300, 500
Este comentário foi feito pelo moderador no site
Olá, isso funciona muito bem. Existe uma maneira de mudar apenas para puxar os valores e não a fórmula?
Obrigado!!
Este comentário foi feito pelo moderador no site
Oi Trish,
O código a seguir pode ajudá-lo a resolver o problema. Obrigado pelo seu comentário.

Submerge2MultiSheets()
Dim xRg como intervalo
Dim xSelItem como variante
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr como string
Escurecer xBook, xWorkBook como pasta de trabalho
Escurecer xSheet como planilha
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Sheet1"
xRgStr = "A1:D4"
Definir xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Com xFileDlg
Se .Mostrar = -1 Então
xSelItem = .SelectedItems.Item(1)
Definir xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("New Sheet")
Se o xSheet não for nada, então
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "New Sheet"
Set xSheet = xWorkBook.Sheets("New Sheet")
Se acabar
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Se xFileName = "" Então Exit Sub
Faça até xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Definir xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir ()
xBook. Fechar
laço
Se acabar
Terminar com
Definir xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Verdadeiro
xRg.UseStandardWidth = Verdadeiro
Application.DisplayAlerts = Verdadeiro
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Este comentário foi feito pelo moderador no site
Oi, ainda está puxando as fórmulas, não os valores, então está me dando um erro #REF. Eu sei que pode precisar de um .PasteSpecial xlPasteValues ​​em algum lugar, mas não consigo descobrir onde. Você pode ajudar? Obrigado!
Este comentário foi feito pelo moderador no site
Oi Obrigado por isso.


Como incluo o código para percorrer todas as pastas e subpastas e executar a cópia acima?


Obrigado!
Este comentário foi feito pelo moderador no site
Oi - Este código é perfeito para o que estou tentando alcançar.

Existe uma maneira de percorrer todas as pastas e subpastas e executar a cópia?


Obrigado!
Este comentário foi feito pelo moderador no site
Oi - Este código funciona muito bem para as primeiras 565 linhas de cada arquivo, mas todas as linhas posteriores são sobrepostas pelo próximo arquivo.
Existe uma maneira de corrigir isso?
Este comentário foi feito pelo moderador no site
Obrigado - como alguém seria capaz de copiar e colar (valores especiais) de cada planilha dentro de uma pasta de trabalho em planilhas separadas dentro de um arquivo mestre principal?
Este comentário foi feito pelo moderador no site
como você faz o código deixar em branco se a célula estiver vazia?
Este comentário foi feito pelo moderador no site
para mim, o nome da guia "Planilha1" muda para cada um dos meus arquivos. Por exemplo, Tab1, Tab2, Tab3, Tab4... Como posso configurar um loop para percorrer uma lista no Excel e continuar alterando o nome "Sheet1" até que ele execute tudo?
Este comentário foi feito pelo moderador no site
Oi Nick, O código VBA abaixo pode ajudá-lo a resolver o problema. Por favor, tente. Sub LoopThroughFileRename()
'Atualizado por Extendofice 2021/12/31
Dim xRg como intervalo
Dim xSelItem como variante
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr como string
Escurecer xBook, xWorkBook como pasta de trabalho
Escurecer xSheet como planilha
Dim xShs como planilhas
Dim xName As String
Dim xFNum como inteiro
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Definir xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Faça enquanto xFileName <> ""
Set xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Definir xShs = xWorkBook.Sheets
Para xFNum = 1 Para xShs.Count
Definir xSheet = xShs.Item(xFNum)
xName = xSheet.Name
xNome = Replace(xNome, "segurança""Aba") 'Substituir Planilha por Tabulação
xSheet.Name = xName
Seguinte
xWorkBook.Salvar
xWorkBook. Fechar
xFileName = Dir ()
laço
Application.DisplayAlerts = Verdadeiro
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Este comentário foi feito pelo moderador no site
Oi, eu quero um código para copiar os dados em 6 pastas de trabalho diferentes (em uma pasta) que possui planilhas incluídas nelas para NOVA WORKBOOK. em vba
por favor me ajude asp
Este comentário foi feito pelo moderador no site
Olá Paranusha,
O script VBA no artigo a seguir pode combinar várias pastas de trabalho ou planilhas de pastas de trabalho especificadas em uma pasta de trabalho mestre. Por favor, verifique se pode ajudar.
Como combinar várias pastas de trabalho em uma pasta de trabalho mestre no Excel?
Este comentário foi feito pelo moderador no site
Ola bom dia.
Os relatórios de códigos gostaram muito, mas não são muito precisos com os códigos que eu gostei.
Preciso imprimir 2.400 relatório de exel que estão em massas diferentes e não estão configuradas corretamente para impressão. Pode me enviar um códgo de VBA que automatize essas impressões? Me ajudaria muito, obrigada.
Este comentário foi feito pelo moderador no site
Olá Maria Soares,
Verifique se o código VBA no post a seguir pode ajudar.
Como imprimir várias pastas de trabalho no Excel?
Este comentário foi feito pelo moderador no site
Meu cenário é semelhante, exceto que tenho várias planilhas em cada arquivo, todas com nomes diferentes, mas consistentes entre os arquivos. Existe uma maneira de fazer um loop neste código para copiar os dados dentro dos arquivos e colar (valores) em nomes de planilhas específicos na pasta de trabalho mestre? Os nomes das planilhas no mestre são os mesmos dos arquivos. Eu quero passar por eles. Além disso, a quantidade de dados em cada planilha varia, então precisarei selecionar os dados em cada planilha usando algo assim:

Faixa("A1").Selecione
Faixa(Seleção, Seleção.Fim(xlPara Baixo)).Selecione
Range(Seleção, Seleção.End(xlToRight)).Selecionar


Os nomes das fichas de arquivo são Doações, Serviços, Seguros, Carro, Outras Despesas, etc...

Obrigado antecipadamente.
Este comentário foi feito pelo moderador no site
Olá André Shahan,
O código VBA a seguir pode resolver seu problema. Depois de executar o código e selecionar uma pasta, o código corresponderá automaticamente à planilha por nome e colará os dados na planilha de mesmo nome na pasta de trabalho mestre.
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Não há comentários postados aqui ainda
Deixe o seu comentário
Postando como convidado
×
Avalie esta postagem:
0   Personagens
Locais sugeridos

Siga-nos

Copyright © 2009 - www.extendoffice.com. | Todos os direitos reservados. Distribuído por ExtendOffice. | | | Mapa do site
Microsoft e o logotipo do Office são marcas comerciais ou marcas registradas da Microsoft Corporation nos Estados Unidos e / ou em outros países.
Protegido por Sectigo SSL