Combining a table from multiple workbooks into one master workbook - excel

Question

I'm new to VBA and trying to combine a table from multiple workbooks and create one big master workbook.
The basic idea is (what I've done so far):
I've created a blank workbook called "Master" with a sheet name " total" and this is the workbook which I want to paste the extracted data into. I created VBA in this workbook.
I have more than 100 source files from which I want to extract a table. They are all in the same directory: "C:\Users\Documents\Test" The sheets are named "Sheet1".
To create the master workbook, I'd like to locate the last row and start copying new values from the next spreadsheet and my codes are currently not working.
Another issue is each table from different workbooks contain its own header (column names) and I want to skip the headers from the second file.
The tables are located in A1:N53 in each workbook.
Here is my current code:
Private Sub Extraction()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Dim strExtension As String
Const strPath As String = "C:\Users\Documents\Test\"
strExtension = Dir(strPath & "*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strExtension)
With wkbSource
LastRow = .Sheets("total").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Sheets("Sheet1").Range("A1:N3" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Close savechanges:=False
End With
strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub
I definitely messed up where it locates data and copy & paste it to the master workbook.
I'd appreciate it if anyone could help me with modifying my code lines.
Thank you in advance.

Answer 1

Sorry, I wrote this script on the go， so I did not get to test it.
It pretty much follows what you were asking.
Execute script from master file. It uses DIR() to loop over all files inside directory and call for Resize sub procedure in order to obtain and transfer the values from range "A1:N53" into master file.
DIR() will iterate through all files inside filepath. For each file, it will grab the data in sheets(1) range("A1:N53") (change it to range("A2:N53") if you dont want header included. Sorry the explanation was a little ambiguous)
Once the data is obtained through the range, the script will simply resize the range and transfers the value into Sheets(master) based on last row count.
Please let me know if it works, it is doesnt, please follow up on the comments and lets work on it!
Thanks,
Script below:
Option Explicit
Dim fpath As String
Dim fname As String
Dim wb As Workbook
Dim twb As Workbook
Dim rgSrc As Range
Dim rgDest As Range
Sub foo()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wb = ThisWorkbook
fpath = "C:\Users\Documents\Test\"
fname = Dir(fpath)
Do While fname <> ""
Set twb = Workbooks.Open(fpath & fname)
Call Resize
twb.Close
fname = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub Resize()
' Get all the data in the current region?change it to "A2:N53" is you dont want header included from the files in filepath
Set rgSrc = twb.Sheets(1).Range("A1:N53")
'Get the range destination
Set rgDest = wb.Sheets("Master").Cells(wb.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
Set rgDest = rgDest.Resize(rgSrc.Rows.Count, rgSrc.Columns.Count)
rgDest.Value2 = rgSrc.Value2
End Sub

Answer 2

You may try the following code that I have been using for some time and appears to be working fine. The promptbox will ask you to select the files and will combine all of them into a stacked database. It will also add a filename so that you can identify the filename from where the data was picked. Code below - Let me know if this helps -
Private Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub MergeSpecificWorkbooks()
Dim MyPath As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant
Dim FirstCell As String
' Set application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
' Change this to the path\folder location of the files.
ChDirNet "C:\Users\nik\test"
FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
FirstCell = "A1"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
' Test if the row of the last cell is equal to or greater than the row of the first cell.
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If the source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close SaveChanges:=False
GoTo ExitTheSub
Else
' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close SaveChanges:=False
End If
Next FNum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub
Function RDB_Last(choice As Integer, rng As Range)
' A choice of 1 = last row.
' A choice of 2 = last column.
' A choice of 3 = last cell.
Dim lrw As Long
Dim lcol As Integer
Select Case choice
Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function