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
