VBA Code--------!

[Thyagaraj]

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

 

[Norman Jones]

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
'<<=============

 

[Norman Jones]

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
'<<=============

 

[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
'<<=============

Dear Norman,

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


Thank u

regards
Thyagaraj