Data Consolidation from Multiple Workbook to a Single Workbook

[Niraj Baraili]

Hi All,
I have multiple files in a folder. I need to open all the files one by one copy data from sheet1 and paste in a another workbook one below other. For this i have written VBA code as below:

Sub LoopthroughDirectory()
Dim myFile As String
Dim erow
Dim filepath As String
Dim Destfile As String
Dim myFileName As String
myFileName = "Consolidated File.xlsx"
Destfile = "D:\Consolidation\Output\"
filepath = "D:\Consolidation\Input\"
myFile = Dir(filepath)
Workbooks.Open (Destfile & "\" & myFileName)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Do While Len(myFile) > 0
 
    Workbooks.Open (filepath & myFile)
    'If There is no data in file then go the next file
    If Range("A2").Value = "" Then
    ActiveWorkbook.Close
    Else
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveWorkbook.Close
    End If
         
    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
    ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 5))
 
     
    myFile = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

But the problem is, in Destination file data is not pasting one below other from source file. Instead of this, data is pasting in Range("A2:E5") in destination file each time.

Any help on this appreciated.

----------------------------------------------------------------------------
Mod Edit: Code Tags added

 

[Asheesh]

You should always tag your VBA codes..see image

 

[Bomino]

Hi,
You could use RDBMerge, Excel Merge Add-in for Excel for Windows:
http://www.rondebruin.nl/win/addins/rdbmerge.htm

 

[Kmahraz]

Hi:
<~~~~~~~~~~~~~~~~Untested~~~~~~~~~~~~~~~~~~~>
Merge a range from every workbook you select (below each other)
I believe this code will meet your needs.
Note: When you run the code you are able to select the files you want to merge.
Fill in the path to the folder
ChDirNet "C:\Users\Ron\test"
And change the sheet and range to yours (see first example). It is also possible to set the start folder with ChDrive and ChDir but I choose to use the SetCurrentDirectoryA function in this example because it also is working with network folders.

Note: Copy all code below in a normal module of your workbook

#If VBA7 Then
Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#Else
Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#End If


Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub

Sub Basic_Example_2()
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
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
ChDirNet "C:\Users\Ron\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 array(myFiles)
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)
Set sourceRange = .Range("A1:C1")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use 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 "Sorry there are not enough rows in the sheet"
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 destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
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 ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub

Source: http://www.rondebruin.nl/win/s3/win008.htm
Note: All code is supplied as assistance to your project. Use it at your own risk and always on a copy of the data you are working with. Excel does not allow you to "undo" macro results - you will need to exit without saving the file and load it again.

 

[Niraj Baraili]

Thanks guys for your help...