VBA Excel - Misture o conteúdo de diversas planilhas em uma única planilha - Merge data from all sheets from multiple workbooks and paste them in single worksheet

Termo de Responsabilidade

Quando estamos criando bases de dados que envolvem informações de bases legadas, ou planilhas antigas, onde em alguns casos precisamos juntas informações de centenas de planilhas, saber automatizar esta parte do processo parece ser bem importante.

Se você não for precisar deste código agora, pelo menos deixa essa página guardada nos seus 'Favoritos', certamente a utilizará no futuro.

Caso você deseja copiar os dados a partir de múltiplas planilhas e colá-los numa única e simples planilhas, poderá usar esse código.

Por exemplo, caso você tenha diversas planilhas gravadas numa única pasta, tal como:

a.xlsx

b.xlsx

c.xlsx

d.xlsx

E em cada uma das planilhas você tivesse múltiplas pastas tais como: Jan, Fev, Mar etc., e você precisasse criar uma nova pasta com o nome de "Data". 

Divirta-se

Option Explicit

Option Explicit

Sub merge_multiple_workbooks()

Dim fldpath

Dim fld, fil, FSO As Object

Dim WKB As Workbook

Dim wks As Worksheet

Dim j As Long, w As Long

Dim stcol As String, lastcol As String

stcol = "A" ' Change the starting column of ur data

lastcol = "C" ' Change the ending column of ur data

' SHOW FOLDER DAILOG BOX

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Choose the folder"

'.InitialFileName = "c:\"

.Show

End With

On Error Resume Next

fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If fldpath = False Then

MsgBox "Folder Not Selected"

Exit Sub

End If

' change sheet names here

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Application.Calculation = xlCalculationManual

Application.StatusBar = True

Application.StatusBar = "Please wait till Macro merge all the files"

Set FSO = CreateObject("scripting.filesystemobject")

Set fld = FSO.getfolder(fldpath)

' browse through all files in source folder

For Each fil In fld.Files

If UCase(Right(fil.Path, 5)) = UCase(".xlsx") And fil.Name <> ThisWorkbook.Name Then

Set WKB = Workbooks.Open(fil.Path)

For Each wks In WKB.Sheets

w = wks.Range("a65356").End(xlUp).Row

' stcol - starting column of my range eg - a

'2 - as my data will start from row 2 because i do not want to copy headers again and again

'lastcol - end column of range eg - c

' w - last filled row in sheet/ ending row of my data

If w >= 2 Then

wks.Range(stcol & "2:" & lastcol & w).Copy _

Destination:=ThisWorkbook.Sheets(1).Range("a65356").End(xlUp).Offset(1, 0)

End If

Next

WKB.Close

End If

Next

MsgBox "Done"

Application.StatusBar = False

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

Reference: 

Tags: VBA, Excel, Tips, folder, pasta, diretório, subdiretório, Get, sub folder, names