Dear Friends,

Can Anybody provide with the vba code for merging all the worksheets of
all the open workbooks.

Ie; all the open workbooks' sheets should be moved to one neew
workbook.


Is this possible.


Regards
Thyagaraj

Hi Thyagaraj,

Can Anybody provide with the vba code for merging all the
worksheets of all the open workbooks.

Ie; all the open workbooks' sheets should be moved to one
neew workbook.

Try something like:

'=============
Public Sub MergeBooks()
Dim destWb As Workbook
Dim WB As Workbook
Dim SH As Worksheet
Dim i As Long
Dim sstr As String
Const sName As String = "My Summary"

sstr = Trim(sName) & " " & Format(Date, "yyyymmdd")

Set destWb = Workbooks.Add(xlWBATWorksheet)
Set SH = destWb.Worksheets(1)
SH.Name = "Summary"

Application.ScreenUpdating = False

With destWb
For Each WB In Application.Workbooks
If WB.Name < .Name _
And UCase(WB.Name) < "PERSONAL.XLS" Then
i = i + 1
WB.Worksheets.Copy after:=.Sheets(.Sheets.Count)
SH.Cells(i, "A").Value = WB.Name
SH.Cells(i, "B").Value = WB.Worksheets.Count
End If
Next WB
End With

destWb.SaveAs Filename:=sstr, _
FileFormat:=xlWorkbookNormal

Application.ScreenUpdating = True

End Sub
'<<=============


---
Regards,
Norman


"Thyagaraj" wrote in message
oups.com...
Dear Friends,

Can Anybody provide with the vba code for merging all the worksheets of
all the open workbooks.

Ie; all the open workbooks' sheets should be moved to one neew
workbook.


Is this possible.


Regards
Thyagaraj

Hi Thyagaraj,

In order to ensure better naming of the summary books worksheets and to
enable indentification of the source of these sheets, try the following
version:

'=============
Public Sub MergeBooks2()
Dim destWb As Workbook
Dim WB As Workbook
Dim SH As Worksheet
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim sstr As String
Dim sStr2 As String
Const sName As String = "My Summary"

sstr = Trim(sName) & " " & Format(Date, "yyyymmdd")

Set destWb = Workbooks.Add(xlWBATWorksheet)
Set SH = destWb.Worksheets(1)
SH.Name = "Summary"

On Error GoTo XIT
Application.ScreenUpdating = False

With destWb
For Each WB In Application.Workbooks
If WB.Name < .Name _
And UCase(WB.Name) < "PERSONAL.XLS" Then
sStr2 = Replace(WB.Name, ".xls", "")
i = i + 1
j = destWb.Sheets.Count
WB.Worksheets.Copy after:=.Sheets(j)
k = destWb.Sheets.Count
For m = j + 1 To k
n = n + 1
destWb.Worksheets(m).Name = sStr2 & " Sh" & CStr(n)
SH.Cells(i, "A").Offset(0, n).Value = WB.Worksheets(n).Name
Next m
SH.Cells(i, "A").Value = WB.Name
j = 0: k = 0: m = 0: n = 0
End If

Next WB
End With

destWb.SaveAs Filename:=sstr, _
FileFormat:=xlWorkbookNormal
XIT:

Application.ScreenUpdating = True

End Sub
'<<=============

---
Regards,
Norman

Norman Jones wrote:
Hi Thyagaraj,

In order to ensure better naming of the summary books worksheets and to
enable indentification of the source of these sheets, try the following
version:

'=============
Public Sub MergeBooks2()
Dim destWb As Workbook
Dim WB As Workbook
Dim SH As Worksheet
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim sstr As String
Dim sStr2 As String
Const sName As String = "My Summary"

sstr = Trim(sName) & " " & Format(Date, "yyyymmdd")

Set destWb = Workbooks.Add(xlWBATWorksheet)
Set SH = destWb.Worksheets(1)
SH.Name = "Summary"

On Error GoTo XIT
Application.ScreenUpdating = False

With destWb
For Each WB In Application.Workbooks
If WB.Name < .Name _
And UCase(WB.Name) < "PERSONAL.XLS" Then
sStr2 = Replace(WB.Name, ".xls", "")
i = i + 1
j = destWb.Sheets.Count
WB.Worksheets.Copy after:=.Sheets(j)
k = destWb.Sheets.Count
For m = j + 1 To k
n = n + 1
destWb.Worksheets(m).Name = sStr2 & " Sh" & CStr(n)
SH.Cells(i, "A").Offset(0, n).Value = WB.Worksheets(n).Name
Next m
SH.Cells(i, "A").Value = WB.Name
j = 0: k = 0: m = 0: n = 0
End If

Next WB
End With

destWb.SaveAs Filename:=sstr, _
FileFormat:=xlWorkbookNormal
XIT:

Application.ScreenUpdating = True

End Sub
'<<=============

---
Regards,
Norman

Dear Norman,

This really great from your side, its working fine...........!


Thank u

regards
Thyagaraj