macro.vba

Option Explicit
'Referência: http://stackoverflow.com/a/26474331/1864883
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

exitFor:
    currentFile.Close
    fileName = Dir()
Loop

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
'Referência: http://stackoverflow.com/a/2051420/1864883
Private Sub Workbook_Open()
    Call MergeFiles        ' Call your macro
    'ActiveWorkbook.Save    ' Save the current workbook, bypassing the prompt
    Application.Quit       ' Quit Excel
End Sub