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

VBA Excel - Obtendo todos os nomes das subpastas de um diretório - Get Names of all the folders stored in a folder/directory Including Sub folder

Termo de Responsabilidade

Ao efetuar pesquisa de relatório gravados em diversas distintas planilhas, é interessante que saibamos pesquisar o local onde ela esteja. Com este código podemos indicar a apartir de onde a busca inicia.

Sub folder_names_including_subfolder()

Application.ScreenUpdating = False

Dim fldpath

Dim fso As Object, j As Long, folder1 As Object

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Choose the folder"

.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

Workbooks.Add

Cells(1, 1).Value = fldpath

Cells(2, 1).Value = "Path"

Cells(2, 2).Value = "Dir"

Cells(2, 3).Value = "Name"

Cells(2, 4).Value = "Date Created"

Cells(2, 5).Value = "Date Last Modified"

Set fso = CreateObject("Scripting.FileSystemObject")

Set folder1 = fso.getfolder(fldpath)

get_sub_folder folder1

Set fso = Nothing

Range("a1").Font.Size = 9

ActiveWindow.DisplayGridlines = False

Range("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 9

Range("a2:e2").Interior.Color = vbCyan

Columns("c:h").AutoFit

Application.ScreenUpdating = True

End Sub

Sub get_sub_folder (ByRef prntfld As Object)

Dim SubFolder As Object, subfld As Object, j As Long

For Each SubFolder In prntfld.SubFolders

j = Range("A1").End(xlDown).Row + 1

Cells(j, 1).Value = SubFolder.Path

Cells(j, 2).Value = Left(SubFolder.Path, InStrRev(SubFolder.Path, "\"))

Cells(j, 3).Value = SubFolder.Name

Cells(j, 4).Value = SubFolder.DateCreated

Cells(j, 5).Value = SubFolder.DateLastModified

Next SubFolder

For Each subfld In prntfld.SubFolders

get_sub_folder subfld

Next subfld

End Sub

Reference: 

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