Workbook Summary Sheet2
 

ryguy7272 thank you for this macro. It is awesome and you wrote the entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

hi TGalin

See the tips section on this page how to do this
http://www.rondebruin.nl/copy2.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm




"TGalin" wrote in message ...
ryguy7272 thank you for this macro. It is awesome and you wrote the entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then
Just add the other sheets
If sh.Name < DestSh.Name _
and sh.name<"Questions") _
and sh.name<"Status" Then

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"TGalin" wrote in message
...
ryguy7272 thank you for this macro. It is awesome and you wrote the
entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted
below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy
the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

Whoooooah!! I didn't write the macro! Ron de Bruin wrote that! I simply
changed a few snippets of Ron's code!

Give this a look when you have some free time (LOTS of free time):
http://www.rondebruin.nl/tips.htm

You will learn quite a bit from that resource. I certainly did!!

Regards,
Ryan---

--
RyGuy


"Don Guillett" wrote:

For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then
Just add the other sheets
If sh.Name < DestSh.Name _
and sh.name<"Questions") _
and sh.name<"Status" Then

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"TGalin" wrote in message
...
ryguy7272 thank you for this macro. It is awesome and you wrote the
entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted
below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy
the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

I tried using this, not sure if I made a mistake, but I am still having
trouble with it. Any thoughts?

"Don Guillett" wrote:

For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then
Just add the other sheets
If sh.Name < DestSh.Name _
and sh.name<"Questions") _
and sh.name<"Status" Then

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"TGalin" wrote in message
...
ryguy7272 thank you for this macro. It is awesome and you wrote the
entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted
below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy
the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

I'll take a look. Thank you!

"Ron de Bruin" wrote:

hi TGalin

See the tips section on this page how to do this
http://www.rondebruin.nl/copy2.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm




"TGalin" wrote in message ...
ryguy7272 thank you for this macro. It is awesome and you wrote the entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

My bad. Sorry for the misunderstanding. I'll take a look. Thanks for the
tip!

"ryguy7272" wrote:

Whoooooah!! I didn't write the macro! Ron de Bruin wrote that! I simply
changed a few snippets of Ron's code!

Give this a look when you have some free time (LOTS of free time):
http://www.rondebruin.nl/tips.htm

You will learn quite a bit from that resource. I certainly did!!

Regards,
Ryan---

--
RyGuy


"Don Guillett" wrote:

For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then
Just add the other sheets
If sh.Name < DestSh.Name _
and sh.name<"Questions") _
and sh.name<"Status" Then

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"TGalin" wrote in message
...
ryguy7272 thank you for this macro. It is awesome and you wrote the
entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted
below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy
the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

I followed you're advice. This part was the key

If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Questions", "Status"), 0)) Then

Thanks for your help!





Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Questions", "Status"), 0)) Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function





"Ron de Bruin" wrote:

hi TGalin

See the tips section on this page how to do this
http://www.rondebruin.nl/copy2.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm




"TGalin" wrote in message ...
ryguy7272 thank you for this macro. It is awesome and you wrote the entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

I figured out what I was missing. This part was the key!

If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Questions", "Status"), 0)) Then

Thanks for your help!



Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Questions", "Status"), 0)) Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function


"Don Guillett" wrote:

For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then
Just add the other sheets
If sh.Name < DestSh.Name _
and sh.name<"Questions") _
and sh.name<"Status" Then

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"TGalin" wrote in message
...
ryguy7272 thank you for this macro. It is awesome and you wrote the
entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted
below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy
the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Workbook Summary Sheet2
 

This part was the key!

If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Questions", "Status"), 0)) Then

Thanks for your help! I would not have gotten this far without you're help.


Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Questions", "Status"), 0)) Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function


"ryguy7272" wrote:

Whoooooah!! I didn't write the macro! Ron de Bruin wrote that! I simply
changed a few snippets of Ron's code!

Give this a look when you have some free time (LOTS of free time):
http://www.rondebruin.nl/tips.htm

You will learn quite a bit from that resource. I certainly did!!

Regards,
Ryan---

--
RyGuy


"Don Guillett" wrote:

For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then
Just add the other sheets
If sh.Name < DestSh.Name _
and sh.name<"Questions") _
and sh.name<"Status" Then

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"TGalin" wrote in message
...
ryguy7272 thank you for this macro. It is awesome and you wrote the
entire
thing. Just wanted to give credit where it's due.

On a separate note I wanted to add one function to the macro I posted
below.
I have two worksheets, one is called Questions and the other is called
Status. I want them to be excluded from the Summary Worksheet that this
macro produces. Can you help me?

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Report"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name < DestSh.Name Then

'Find the last row with data on the DestSh
Last = LastRow(DestSh)

'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:B24")

'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If

'This example copies values/formats, if you only want to copy
the
'values or want to copy everything look at the example below
this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value =
sh.Name

End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function