VBA – Combinar Vários Arquivos do Excel em uma Pasta de Trabalho

Este tutorial mostrará como combinar vários arquivos do Excel em uma pasta de trabalho no VBA.

A criação de uma única pasta de trabalho a partir de várias pastas de trabalho usando o VBA requer o cumprimento de várias etapas.

• Você precisa selecionar as pastas de trabalho das quais deseja obter os dados de origem – os arquivos de origem.
• Você precisa selecionar ou criar a pasta de trabalho na qual deseja colocar os dados – o arquivo de destino.
• Você precisa selecionar as planilhas dos arquivos de origem que deseja.
• Você precisa informar ao código onde colocar os dados no arquivo de destino.

Combinação de Todas as Planilhas de Todas as Pastas de Trabalho Abertas em uma Nova Pasta de Trabalho como Planilhas Individuais

No código abaixo, os arquivos dos quais você precisa copiar as informações precisam estar abertos, pois o Excel percorrerá os arquivos abertos e copiará as informações em uma nova pasta de trabalho. O código é colocado na pasta de trabalho Macro pessoal.

Esses arquivos são os ÚNICOS arquivos do Excel que devem estar abertos.

Sub CombinarMultiplosArquivos()
On Error GoTo eh
'declarar variáveis para conter os objetos necessários
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
'desativar a atualização da tela para acelerar o processo
   Application.ScreenUpdating = False
'Primeiro, crie uma nova pasta de trabalho de destino
   Set wbDestination = Workbooks.Add
'obter o nome da nova pasta de trabalho para que você a exclua do loop abaixo
   strDestName = wbDestination.Name
'Agora, faça um loop em cada uma das pastas de trabalho abertas para obter os dados, 
'mas exclua seu novo arquivo ou a pasta de trabalho de macro Pessoal
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets
            sh.Copy After:=Workbooks(strDestName).Sheets(1)
         Next sh
      End If
   Next wb
'agora feche todos os arquivos abertos, exceto o novo arquivo e a pasta de trabalho da macro Personal.
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb

'remover a planilha um da pasta de trabalho de destino
   Application.DisplayAlerts = False
   Sheets("Planilha1").Delete
   Application.DisplayAlerts = True
'limpar os objetos para liberar a memória
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsSource = Nothing
   Set wb = Nothing
'ativar a atualização da tela quando concluída
   Application.ScreenUpdating = False
Exit Sub
eh:
   MsgBox Err.Description
End Sub

Clique na caixa de diálogo Macro para executar o procedimento na tela do Excel.

Seu arquivo combinado será exibido.

Esse código percorreu cada arquivo e copiou a planilha para um novo arquivo. Se algum dos seus arquivos tiver mais de uma planilha, ele as copiará também, inclusive as planilhas sem nada!

Combinação de Todas as Planilhas de Todas as Pastas de Trabalho Abertas em uma Única Planilha em uma Nova Pasta de Trabalho

O procedimento abaixo combina as informações de todas as planilhas de todas as pastas de trabalho abertas em uma única planilha em uma nova pasta de trabalho que é criada.

As informações de cada planilha são coladas na planilha de destino na última linha ocupada na planilha.

‘—————- falta testar a macro abaixo ———————–

Sub CombinarMultiplasPlanilhas()
On Error GoTo eh
'declarar variáveis para conter os objetos necessários
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim strEndRng As String
   Dim rngSource As Range
'desativar a atualização da tela para acelerar o processo
   Application.ScreenUpdating = False
'Primeiro, crie uma nova pasta de trabalho de destino
   Set wbDestination = Workbooks.Add
'obter o nome da nova pasta de trabalho para que você a exclua do loop abaixo
   strDestName = wbDestination.Name
'Agora, faça um loop em cada uma das pastas de trabalho abertas para obter os dados
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets
'obter o número de linhas e colunas na planilha
            sh.Activate
            ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
            iRws = ActiveCell.Row
            iCols = ActiveCell.Column
'definir o intervalo da última célula da planilha
            strEndRng = sh.Cells(iRws, iCols).Address
'definir o intervalo de origem a ser copiado
            Set rngSource = sh.Range("A1:" & strEndRng)
'encontrar a última linha na planilha de destino
           wbDestination.Activate
           Set wsDestination = ActiveSheet
           wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
           totRws = ActiveCell.Row
'verificar se há linhas suficientes para colar os dados
           If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
               MsgBox "Não há linhas suficientes para colocar os dados na planilha Consolidação."
               GoTo eh
           End If
'adicionar uma linha para colar na próxima linha abaixo
           If totRws <> 1 Then totRws = totRws + 1
           rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
      Next sh
   End If
   Next wb
'agora feche todos os arquivos abertos, exceto o que você deseja
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb
'limpar os objetos para liberar a memória
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'ativar a atualização da tela quando concluída
   Application.ScreenUpdating = False
Exit Sub
eh:
MsgBox Err.Description
End Sub

Combinação de Todas as Planilhas de Todas as Pastas de Trabalho Abertas em uma Única Planilha em uma Pasta de Trabalho Ativa

Se quiser trazer as informações de todas as outras pastas de trabalho abertas para aquela em que está trabalhando no momento, você pode usar o código abaixo.

Sub CombinarMultiplasPlanilhasComExistente()
   On Error GoTo eh
'declarar variáveis para conter os objetos necessários
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim rngEnd As String
   Dim rngSource As Range
'definir o objeto de pasta de trabalho ativa para o arquivo de destino
   Set wbDestination = ActiveWorkbook
'obter o nome do arquivo ativo
   strDestName = wbDestination.Name
'desativar a atualização da tela para acelerar o processo
   Application.ScreenUpdating = False
'Primeiro, crie uma nova planilha de destino em sua pasta de trabalho ativa
   Application.DisplayAlerts = False
'Continuar se encontrar erro, caso a planilha não exista
   On Error Resume Next
   ActiveWorkbook.Sheets("Consolidação").Delete
'redefinir a armadilha de erro para ir para a armadilha de erro no final
   On Error GoTo eh
   Application.DisplayAlerts = True
'adicionar uma nova planilha à pasta de trabalho
   With ActiveWorkbook
      Set wsDestination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
      wsDestination.Name = "Consolidação"
   End With
'Agora, faça um loop em cada uma das pastas de trabalho abertas para obter os dados
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
            For Each sh In wbSource.Worksheets
'obter o número de linhas na planilha
               sh.Activate
               ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
               iRws = ActiveCell.Row
               iCols = ActiveCell.Column
               rngEnd = sh.Cells(iRws, iCols).Address
               Set rngSource = sh.Range("A1:" & rngEnd)
'encontrar a última linha na planilha de destino
               wbDestination.Activate
               Set wsDestination = ActiveSheet
               wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
               totRws = ActiveCell.Row
'verificar se há linhas suficientes para colar os dados
               If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
                  MsgBox "Não há linhas suficientes para colocar os dados na planilha Consolidação."
                  GoTo eh
               End If
'adicionar uma linha para colar na próxima linha abaixo se você não estiver na linha 1
               If totRws <> 1 Then totRws = totRws + 1
               rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
           Next sh
         End If
   Next wb
'agora feche todos os arquivos abertos, exceto o que você deseja
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb

'limpar os objetos para liberar a memória
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'ativar a atualização da tela quando concluída
   Application.ScreenUpdating = False
Exit Sub
eh:
MsgBox Err.Description
End Sub