CopyPasteCode

[TGalin]

I have a workbook with 50 worksheets. If I wanted to gather all the data
from each worksheet and then paste it onto one worksheet named Report, I
could use the following code and repeat until I have covered all 50
worksheets. However I am wondering can this code be shortened as well as
modified so that it only copies cells from the range A1:B24 that have
contents inside them? Also on the reports page where all the results are
pasted into Column A, is it possible to delete the rows that do not have any
contents in them?

Sub CopyPasteCode()
Sheets.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Report"
Sheets("Quest 1").Select
Range("A1:B24").Select
Selection.Copy
Sheets("Report").Select
ActiveSheet.Paste
Sheets("Quest 2").Select
Range("A1:B24").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Report").Select
Range("A25").Select
ActiveSheet.Paste
Sheets("Quest 3").Select
Range("A1:B24").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Report").Select
Range("A49").Select
ActiveSheet.Paste
End Sub

 

[ryguy7272]

Take a look at this:
http://www.rondebruin.nl/copy2.htm

Also, to delete blank rows, if there is a blanks in ColumnA, run this code:
Sub delete_rows()

Dim RowNdx As Long
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
For RowNdx = LastRow To 1 Step -1
If Cells(RowNdx, "A").Value = "" Then
Rows(RowNdx).Delete
End If
Next RowNdx

End Sub

To delete blank rows, if the entire row is blank, run this code:
Public Sub DeleteBlankRows()

Dim R As Long
Dim C As Range
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If
For R = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(R).EntireRow) = 0 Then
Rng.Rows(R).EntireRow.Delete
End If
Next R

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub


IMPORTANT!! Make a backup of your file before doing any of this stuff.
There is nothing more annoying than deleting things, accidentally, because
you ran code and it did not do what you thought it would do.

Regards,
Ryan---

 

[TGalin]

Here is the code I tried, but it didn't work. Any ideas?

Sub CopyRangeFromMultiWorksheets()
Set CopyRng = sh.UsedRange
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 = "RDBMergeSheet"

'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:G1")

'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

With CopyRng
DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With

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

 

[JLGWhiz]

I did not try to run the code, but one thing I noticed was that you declared
your object variable CopyRng before you initialize the sh variable. That
would make the CopyRng variable equal to "empty" at the time you try to use
it. Here is where I think it should be:

For Each sh In ActiveWorkbook.Worksheets
Set CopyRng = sh.UsedRange '<<<move it to here after sh initialize
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:G1")
'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
With CopyRng
DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With
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

 

[KC]

We cannot find reference to LastRow(DestSh)

Here is the code I tried, but it didn't work. Any ideas?

Sub CopyRangeFromMultiWorksheets()
Set CopyRng = sh.UsedRange
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 = "RDBMergeSheet"

'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:G1")

'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

With CopyRng
DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
.Columns.Count).Value = .Value
End With

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

 

[Ron de Bruin]

Hi KC

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

--

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