Merge Sheets
 

I have a workbook with a Sheet named Main Data. The sheet named Main Data, I
want to leave alone. The remaining 19 or 20 worksheets (the number of sheets
can vary), I would like to take the range A2 to the last row in AH that has
contents in it and paste those ranges from each worksheet into one new
worksheet so that they do not overlap. I put below the code that I have now
which works fine when I have 9 to 10 worksheets, but when I have 19 to 20
worksheets it doesnt work as well. Your help I appreciate. Thank you for
your suggestions.


Dim wksSum As Worksheet
Dim wks As Worksheet
Dim rCopy As Range
Dim lRow As Long

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

..DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
..DisplayAlerts = True

Set wksSum = ActiveWorkbook.Worksheets.Add
wksSum.Name = "Summary Report"

wksSum.Range("A1:AH1").Value = Worksheets("Main Data").Range("A1:AH1").Value

For Each wks In ActiveWorkbook.Worksheets
With wks
If .Name < wksSum.Name And .Name < "Main Data" Then
Set rCopy = .Range("A2", .Cells(.Rows.Count, "AH").End(xlUp))

lRow = wksSum.Cells(wksSum.Rows.Count, "A").End(xlUp).Row
If lRow + rCopy.Rows.Count wksSum.Rows.Count Then
MsgBox "Not enough rows in Summary sheet to add sheet " & .Name
GoTo ExitTheSub
End If

rCopy.Copy
With wksSum.Cells(lRow + 1, "A")
..PasteSpecial xlPasteValues
..PasteSpecial xlPasteFormats
End With

wksSum.Cells(lRow + 1, "AH").Resize(rCopy.Rows.Count).Value = .Name
End If
End With
Next wks

ExitTheSub:
..CutCopyMode = False
..GoTo wksSum.Cells(1)
..ScreenUpdating = True
..EnableEvents = True
End With

End sub

Merge Sheets
 

Hi Sal

See
http://www.rondebruin.nl/copy2.htm

Download the example workbook to test the code

--

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




"Sal" wrote in message ...
I have a workbook with a Sheet named Main Data. The sheet named Main Data, I
want to leave alone. The remaining 19 or 20 worksheets (the number of sheets
can vary), I would like to take the range A2 to the last row in AH that has
contents in it and paste those ranges from each worksheet into one new
worksheet so that they do not overlap. I put below the code that I have now
which works fine when I have 9 to 10 worksheets, but when I have 19 to 20
worksheets it doesnt work as well. Your help I appreciate. Thank you for
your suggestions.


Dim wksSum As Worksheet
Dim wks As Worksheet
Dim rCopy As Range
Dim lRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False

.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
.DisplayAlerts = True

Set wksSum = ActiveWorkbook.Worksheets.Add
wksSum.Name = "Summary Report"

wksSum.Range("A1:AH1").Value = Worksheets("Main Data").Range("A1:AH1").Value

For Each wks In ActiveWorkbook.Worksheets
With wks
If .Name < wksSum.Name And .Name < "Main Data" Then
Set rCopy = .Range("A2", .Cells(.Rows.Count, "AH").End(xlUp))

lRow = wksSum.Cells(wksSum.Rows.Count, "A").End(xlUp).Row
If lRow + rCopy.Rows.Count wksSum.Rows.Count Then
MsgBox "Not enough rows in Summary sheet to add sheet " & .Name
GoTo ExitTheSub
End If

rCopy.Copy
With wksSum.Cells(lRow + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With

wksSum.Cells(lRow + 1, "AH").Resize(rCopy.Rows.Count).Value = .Name
End If
End With
Next wks

ExitTheSub:
.CutCopyMode = False
.GoTo wksSum.Cells(1)
.ScreenUpdating = True
.EnableEvents = True
End With

End sub

Merge Sheets
 

Thanks.

"Ron de Bruin" wrote:

Hi Sal

See
http://www.rondebruin.nl/copy2.htm

Download the example workbook to test the code

--

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




"Sal" wrote in message ...
I have a workbook with a Sheet named Main Data. The sheet named Main Data, I
want to leave alone. The remaining 19 or 20 worksheets (the number of sheets
can vary), I would like to take the range A2 to the last row in AH that has
contents in it and paste those ranges from each worksheet into one new
worksheet so that they do not overlap. I put below the code that I have now
which works fine when I have 9 to 10 worksheets, but when I have 19 to 20
worksheets it doesnt work as well. Your help I appreciate. Thank you for
your suggestions.


Dim wksSum As Worksheet
Dim wks As Worksheet
Dim rCopy As Range
Dim lRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False

.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
.DisplayAlerts = True

Set wksSum = ActiveWorkbook.Worksheets.Add
wksSum.Name = "Summary Report"

wksSum.Range("A1:AH1").Value = Worksheets("Main Data").Range("A1:AH1").Value

For Each wks In ActiveWorkbook.Worksheets
With wks
If .Name < wksSum.Name And .Name < "Main Data" Then
Set rCopy = .Range("A2", .Cells(.Rows.Count, "AH").End(xlUp))

lRow = wksSum.Cells(wksSum.Rows.Count, "A").End(xlUp).Row
If lRow + rCopy.Rows.Count wksSum.Rows.Count Then
MsgBox "Not enough rows in Summary sheet to add sheet " & .Name
GoTo ExitTheSub
End If

rCopy.Copy
With wksSum.Cells(lRow + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With

wksSum.Cells(lRow + 1, "AH").Resize(rCopy.Rows.Count).Value = .Name
End If
End With
Next wks

ExitTheSub:
.CutCopyMode = False
.GoTo wksSum.Cells(1)
.ScreenUpdating = True
.EnableEvents = True
End With

End sub