Saturday, 23 March 2013

How To Cobine or Merge or Consolidate or Import or Export Data From Multiple Workbooks Into One Sheet

Excel VBA Macro To Cobine or Merge or Consolidate or Import or Export Data from All Sheets of  Multiple Workbooks Into Single Sheet of Another New Workbook

Sub Consol_All_Books2OneSheet()

Dim LastDataRow As Long
Dim LastDataColumn As Long
Dim MyDataRange As Object
Dim WS As Worksheet
Dim DataSource As String

On Error Resume Next

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error Resume Next

Export2File = Format(Now(), " DD_MM_YYYY HH-MM AMPM ")


'Target File location into which files are to be Merge.....Change as you wish.......

Workbooks.Add(xlWBATWorksheet).SaveAs FileName:="D:\MBA\" & Export2File & ".xlsm ", FileFormat:=52
'FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
Set TargetFile = ActiveWorkbook
ActiveWorkbook.Sheets(1).Name = "Consolidate"

'Source File location from which files are to be Export.....Change as you wish.......

SourcePath = "C:\Documents and Settings\Administrator\My Documents\"
SrcFileName = Dir(SourcePath & "*.xls*")
    
Do While SrcFileName <> ""
Set SourceFile = Workbooks.Open(FolderPath & SrcFileName)
For Each WS In SourceFile.Sheets
WS.Activate

DataSource = "Source: [" & "Workbook Name:" & " " & ActiveWorkbook.Name & " " & _

"|" & "Sheet Name:" & " " & WS.Name & "|" & "Path :" & " " & ThisWorkbook.Path & "]"

LastDataRow = ActiveSheet.Cells.Find(what:="*", SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious).Row

LastDataColumn = ActiveSheet.Cells.Find(what:="*", SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious).Column

Set MyDataRange = ActiveSheet.Range(Cells(1, 1).Offset(LastDataRow, 0), Cells(1, 1).Offset(0, LastDataColumn))

MyDataRange.Copy

TargetFile.Sheets("Consolidate").Activate

TargetDataRow = ActiveSheet.Cells.Find(what:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

If TargetDataRow = "" Then

Cells(2, 1).Select
ActiveSheet.Paste
Cells(1, 1).Value = DataSource
Cells(1, 1).Font.Bold = True
Else:
Cells(TargetDataRow, 1).Offset(3, 0).Select
ActiveSheet.Paste
Cells(TargetDataRow, 1).Offset(2, 0).Value = DataSource
Cells(TargetDataRow, 1).Offset(2, 0).Font.Bold = True
End If

Next WS

SourceFile.Activate
ActiveWorkbook.Close SaveChanges:=False
    
SrcFileName = Dir() 'Allows to Go to Next File in a Directory
Loop

TargetFile.Close SaveChanges:=True

    
Application.EnableEvents = True
Application.DisplayAlerts = True
    
MsgBox "All Wokbooks with All Sheets Successfllly Exported To Target File Sheet", vbInformation, "Successfully Exported !"
End Sub


Thanks.,

Tamatam

No comments:

Post a Comment

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts