Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
CopyPasteCode
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
CopyPasteCode
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).E ntireRow) = 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--- -- RyGuy "TGalin" wrote: 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
CopyPasteCode
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 "ryguy7272" wrote: 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).E ntireRow) = 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--- -- RyGuy "TGalin" wrote: 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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
CopyPasteCode
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 "TGalin" wrote in message ... 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 "ryguy7272" wrote: 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).E ntireRow) = 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--- -- RyGuy "TGalin" wrote: 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
CopyPasteCode
We cannot find reference to LastRow(DestSh)
"TGalin" wrote in message ... 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 "ryguy7272" wrote: 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).E ntireRow) = 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--- -- RyGuy "TGalin" wrote: 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
CopyPasteCode
Hi KC
See http://www.rondebruin.nl/copy2.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "KC" wrote in message ... We cannot find reference to LastRow(DestSh) "TGalin" wrote in message ... 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 "ryguy7272" wrote: 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).E ntireRow) = 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--- -- RyGuy "TGalin" wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|