Combine multiple Workbooks into One New Workbook

[SandeepKumar]

Hi All,

I need a macro for combing 3 workbooks into one new workbook.
For example a excel file contains list of files in coulmn A ,B and C and in Column E new file name .
I need to update all three workbooks without saving the actual workbook combine all workbook into One workbook .

Here is the code that I am using but stuck in combing files into One .
Need help!!!!

Public sPath As StringPublic sDriverFname As String
Public sLang As String
Public sCmpFname As String
Public sCmpFnameEN As String
Public sPsrFname As String
Public sPsrFnameEN As String
Public sIFname As String
Public sIFnameEN As String
Public sPickerFname As String
Public sPickerFnameEN As String
Public bENversion As Boolean


Sub OpenFiles()
Application.DisplayAlerts = False
On Error GoTo FileErr
Workbooks.Open Filename:=sPath & "\" & sCmpFname
Workbooks.Open Filename:=sPath & "\" & sPsrFname
Workbooks.Open Filename:=sPath & "\" & sIFname
Application.DisplayAlerts = True

Exit Sub


FileErr:
MsgBox ("Error openning file for : " & sLang & ". Check files exist in directory.")
End Sub
Sub CloseFiles()
Workbooks(sCmpFname).Activate
ActiveWorkbook.Close SaveChanges:=False
Workbooks(sPsrFname).Activate
ActiveWorkbook.Close SaveChanges:=False
Workbooks(sIFname).Activate
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=sPath & "\" & sPickerFname
ActiveWorkbook.Close
Application.DisplayAlerts = True
Workbooks(sDriverFname).Activate
End Sub




Sub CreateRpt()
' Determine language column for sheet names

Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet




Application.ScreenUpdating = False

Workbooks(sDriverFname).Activate
Sheets("1").Activate

sInput = sIFname
sCmp = sCmpFname
sPsr = sPsrFname
sPick = sPickerFname
nTransCol = nLangCol


' Add D blocks R nums and re-name sheets to input forms
Workbooks(sInput).Activate
nShNameRow = 32
For nSheet = 1 To Sheets.Count
Sheets(nSheet).Activate
For Each CELL In ActiveSheet.UsedRange
If (IsNumeric(CELL.Value) And CELL.Value <> "") Then
CELL.Value = "D1:R" & CELL.Value
End If
Next CELL
Workbooks(sInput).Activate
Next nSheet

' Add composite pages to input form file
nSheetPos = 1
nShNameRow = 2
Workbooks(sCmp).Activate
For nSheet = 1 To Sheets.Count
Workbooks(sDriverFname).Activate
Sheets("1").Activate
bShName = True
sClearCol = Cells(nShNameRow, 4).Value
Workbooks(sCmp).Activate
Sheets(nSheet).Activate
Sheets(nSheet).Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Workbooks(sInput).Activate
Sheets.Add(Before:=Sheets(nSheetPos)).Name = sInput
ActiveSheet.Paste
Cells.Select
Selection.RowHeight = 14.25
sDeleteRange = sClearCol & ":AD"
Range(sDeleteRange).Delete
sDeleteRange = "A2:AD5"
Range(sDeleteRange).Delete
sDeleteRange = sClearCol & "3:AD100"
Range(sDeleteRange).ClearContents
Cells(2, 4).Value = ""
Range("A1").Select
nSheetPos = nSheetPos + 1

Next nSheet

' Add Perf. Sum rpt pages to result of above
nShNameRow = 27
Workbooks(sPsr).Activate
For nSheet = 1 To Sheets.Count - 3
Workbooks(sDriverFname).Activate
Sheets("1").Activate
sShName = Cells(nShNameRow, nTransCol).Value
sClearCol = Cells(nShNameRow, 4).Value
nShNameRow = nShNameRow + 1
Workbooks(sPsr).Activate
Sheets(nSheet).Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Workbooks(sInput).Activate

Sheets.Add(Before:=Sheets(nSheetPos)).Name = sPsr
Range("A1").Select
ActiveSheet.Paste
sDeleteRange = sClearCol & ":AD"
Range(sDeleteRange).Delete
sDeleteRange = "A5:AD5"
Range(sDeleteRange).Delete
Cells.Select
Selection.RowHeight = 14.25
With Selection.Font
.ColorIndex = xlAutomatic
End With
For Each CELL In ActiveSheet.UsedRange
If (CELL.Interior.Color = RGB(0, 0, 0)) Then
CELL.Interior.Color = RGB(255, 255, 255)
End If
Next CELL
' Remove charts
If Sheets(sShName).ChartObjects.Count > 0 Then
Sheets(sShName).ChartObjects.Delete
End If
' Remove logos
Dim Pic As Object
For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic

Range("A1").Select
Sheets(1).Select
nSheetPos = nSheetPos + 1
Workbooks(sPsr).Activate
Next nSheet

Application.ScreenUpdating = True


End Sub

Sub Main()
sPath = ActiveWorkbook.Path
sDriverFname = ActiveWorkbook.Name
nRow = 2 'Files names from Row 2
While (Workbooks(sDriverFname).Sheets("1").Cells(nRow, 1).Value <> "") 'Until blank is not found
sCmpFname = Workbooks(sDriverFname).Sheets("1").Cells(nRow, 1).Value
sPsrFname = Workbooks(sDriverFname).Sheets("1").Cells(nRow, 2).Value & ".xls"
sIFname = Workbooks(sDriverFname).Sheets("1").Cells(nRow, 3).Value & ".xls"
sPickerFname = Workbooks(sDriverFname).Sheets("1").Cells(nRow, 5).Value
Call OpenFiles
Call CreateRpt
Call CloseFiles
nRow = nRow + 1
Wend

End Sub