Skip to content

Instantly share code, notes, and snippets.



Created Jul 18, 2016
What would you like to do?
Option Explicit
Private Sub MergeFiles()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String, currentFile As Workbook, thisFile As Workbook, output As Workbook, outputName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set thisFile = ActiveWorkbook 'Referencia para planilha atual
directory = thisFile.Sheets("teste1").Cells(1, 2).Value 'Recupera diretorio de arquivos para juntar de celula B1
outputName = thisFile.Sheets("teste1").Cells(2, 2).Value 'Recupera nome do arquivo de saida de celula B2
fileName = Dir(directory & "*.xl??")
Set output = Workbooks.Add 'Cria novo arquivo de saida
Do While fileName <> ""
Set currentFile = Workbooks.Open(directory & fileName) 'Abre arquivo a juntar como currentFile
WrdArray() = Split(fileName, ".") 'Divide o nome do arquivo por `.` em um array
For Each sheet In currentFile.Worksheets 'Percorre cara planilha do arquivo de entrado atual
currentFile.ActiveSheet.Name = WrdArray(0) 'Muda nome da planialia atual para o nome do arquivo
sheetsInOutput = output.Worksheets.Count 'Conta o numero de planilhas no arquivo de saida
currentFile.Worksheets(sheet.Name).Copy after:=output.Worksheets(sheetsInOutput)
GoTo exitFor:
Next sheet
fileName = Dir()
output.Worksheets(1).Delete 'Apaga primeira planilha vazia que é criado junto com arquivo novo
output.SaveAs fileName:=thisFile.Path & "\" & outputName 'Salva arquivo de saida no mesmo diretório que esta sendo executado
output.Close 'Fecha arquivo de saida
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub Workbook_Open()
Call MergeFiles ' Call your macro
'ActiveWorkbook.Save ' Save the current workbook, bypassing the prompt
Application.Quit ' Quit Excel
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment