Note: The other languages of the website are Google-translated. Back to English
Registo de cliente  \/ 
x
or
x
Registe-se  \/ 
x

or

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

Importante:

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-2019 e 365. Suporta todos os idiomas. Fácil implantação em sua empresa ou organização. Teste gratuito de 30 dias com recursos completos. 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
Say something here...
symbols left.
You are guest
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Nick · 1 months ago
    for me, the "Sheet1" tab name changes for each of my files. For instance, Tab1, Tab2, Tab3, Tab4...
    How can I setup a loop to run through a list in excel and keep changing the "Sheet1" name until it runs through everything?
    • To post as a guest, your comment is unpublished.
      crystal · 22 days ago
      Hi Nick,
      The VBA code below can help you solve the problem. Please have a try.
      Sub LoopThroughFileRename() 'Updated by Extendofice 2021/12/31 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 Dim xShs As Sheets Dim xName As String Dim xFNum As Integer On Error Resume Next Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = False Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker) xFileDlg.Show xSelItem = xFileDlg.SelectedItems.Item(1) xFileName = Dir(xSelItem & "\*.xlsx", vbNormal) Do While xFileName <> "" Set xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName) Set xShs = xWorkBook.Sheets For xFNum = 1 To xShs.Count Set xSheet = xShs.Item(xFNum) xName = xSheet.Name xName = Replace(xName, "Sheet", "Tab") 'Replace Sheet with Tab xSheet.Name = xName Next xWorkBook.Save xWorkBook.Close xFileName = Dir() Loop Application.DisplayAlerts = True Application.EnableEvents = True Application.ScreenUpdating = True End Sub

  • To post as a guest, your comment is unpublished.
    juan · 2 months ago
    how do you make to code leave a blank if cell is empty?

  • To post as a guest, your comment is unpublished.
    Ouen A · 7 months ago
    Thank you - how would one be able to copy and paste (special values) from each worksheet within a workbook into separate sheets within a main Master file?
  • To post as a guest, your comment is unpublished.
    Alexander Høgh · 1 years ago
    Hi - This code works very well for the first 565 lines for every file, but all lines after are overlapped by the next file.
    is there a way to fix this?
  • To post as a guest, your comment is unpublished.
    dan.tran2908@gmail.com · 2 years ago
    Hi - This code is perfect for what I'm trying to achieve.

    Is there a way to loop through all folders and subfolders and perform the copy?


    Thanks!
  • To post as a guest, your comment is unpublished.
    Dan · 2 years ago
    Hi Thanks for this.


    How do I include the code to loop through all folders and subfolders and perform the above copy?


    Thanks!
  • To post as a guest, your comment is unpublished.
    Trish · 2 years ago
    Hi there, This works great. Is there a way to change to just pull over the values and not the formula?
    Thanks!!
    • To post as a guest, your comment is unpublished.
      crystal · 2 years ago
      Hi Trish,
      The following code can help you solve the problem. Thank you for your comment.

      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
      Set xRg = xSheet.UsedRange
      xRg.ClearFormats
      xRg.UseStandardHeight = True
      xRg.UseStandardWidth = True
      Application.DisplayAlerts = True
      Application.EnableEvents = True
      Application.ScreenUpdating = True
      End Sub
      • To post as a guest, your comment is unpublished.
        Luisa · 1 months ago
        Hi, it's still pulling the formulas, not the values, so it's giving me a #REF error. I know it might need a .PasteSpecial xlPasteValues somewhere, but I can't figure out where. Can you help? Thanks!
  • To post as a guest, your comment is unpublished.
    Robertson · 2 years ago
    Hello,

    Thank you for the tutorial.

    How would I: Only copy the row in "Sheet1" with values from the "total" row and paste with [filename] in master worksheet named “New Sheet”. Noting the row with Total can be different in each worksheet.

    For example:
    File1: Sheet1
    Col1,Col2,Colx
    1,2,15
    Result,10,50

    File2: Sheet1
    Col1,Col2,Colx
    1,5,10
    2,4,16
    3,3,6
    4,5,6
    5,7,10
    Result,300,500

    MasterFile: "New Sheet":
    file1, 10, 50
    file2, 300, 500
  • To post as a guest, your comment is unpublished.
    thechubbs · 2 years ago
    Hi, thanks for the code. Please can you let me know how I can include the Excel file name from which the data range was copied? This would be a great help!

    Thank you.
  • To post as a guest, your comment is unpublished.
    lai ling · 3 years ago
    thank you for the vba code! It works perfectly! Would like to know what is the code if i need to PASTE AS VALUE instead? Thx in advance!
    • To post as a guest, your comment is unpublished.
      crystal · 2 years ago
      Hi Lai Ling,
      The following code can help you solve the problem. Thank you for your comment.

      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
      Set xRg = xSheet.UsedRange
      xRg.ClearFormats
      xRg.UseStandardHeight = True
      xRg.UseStandardWidth = True
      Application.DisplayAlerts = True
      Application.EnableEvents = True
      Application.ScreenUpdating = True
      End Sub