Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
Ron DeBruin's Merge Worksheets Example
Hello,
I am trying to modify Ron DeBruin's "Merge Cells from all or some worksheets into one Mastersheet" function but need to have a special condition inserted and I am not sure how to do it. I am not very good with VBA, but have had some success with modifying code. Specifically, I want to be able to copy data that appears in columns A - AH provided that column B has a value greater than zero. Currently I have in column B either; a 5 digit number, the word "Enter", or it is null. I only want to copy rows that have the five digital number (which is why I am thinking greater than zero). I have seven worksheets that I will be copying data from. I have pasted Ron's code below in the event it is an easy tweak. Thanks in advance. 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 = "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 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 |
#2
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
Ron DeBruin's Merge Worksheets Example
You can run this macro on the RDBMergesheet with all the data
Sub Union_Example() Dim Firstrow As Long Dim Lastrow As Long Dim Lrow As Long Dim CalcMode As Long Dim ViewMode As Long Dim rng As Range With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With 'We use the ActiveSheet but you can replace this with 'Sheets("MySheet")if you want With ActiveSheet 'We select the sheet so we can change the window view .Select 'If you are in Page Break Preview Or Page Layout view go 'back to normal view, we do this for speed ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView 'Turn off Page Breaks, we do this for speed .DisplayPageBreaks = False 'Set the first and last row to loop through Firstrow = .UsedRange.Cells(1).Row Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row 'We loop from Lastrow to Firstrow (bottom to top) For Lrow = Lastrow To Firstrow Step -1 'We check the values in the A column in this example With .Cells(Lrow, "B") If Not IsError(.Value) Then If Not IsNumeric(.Value) Or .Value = 0 Then If rng Is Nothing Then Set rng = .Cells Else Set rng = Application.Union(rng, .Cells) End If End If End If End With Next Lrow End With 'Delete all rows in one time If Not rng Is Nothing Then rng.EntireRow.Delete ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ScottMSP" wrote in message ... Hello, I am trying to modify Ron DeBruin's "Merge Cells from all or some worksheets into one Mastersheet" function but need to have a special condition inserted and I am not sure how to do it. I am not very good with VBA, but have had some success with modifying code. Specifically, I want to be able to copy data that appears in columns A - AH provided that column B has a value greater than zero. Currently I have in column B either; a 5 digit number, the word "Enter", or it is null. I only want to copy rows that have the five digital number (which is why I am thinking greater than zero). I have seven worksheets that I will be copying data from. I have pasted Ron's code below in the event it is an easy tweak. Thanks in advance. 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 = "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 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 |
#3
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
Ron DeBruin's Merge Worksheets Example
Thanks Ron. That was very helpful.
PS. I posted a follow-up question in a new thread. Your response to my question was successful so I wanted to be sure that it was acknowledge by clicking yes and I thought it best to start a new thread because it was a different question (although related to the same Macro). Thanks again for all your help. "Ron de Bruin" wrote: You can run this macro on the RDBMergesheet with all the data Sub Union_Example() Dim Firstrow As Long Dim Lastrow As Long Dim Lrow As Long Dim CalcMode As Long Dim ViewMode As Long Dim rng As Range With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With 'We use the ActiveSheet but you can replace this with 'Sheets("MySheet")if you want With ActiveSheet 'We select the sheet so we can change the window view .Select 'If you are in Page Break Preview Or Page Layout view go 'back to normal view, we do this for speed ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView 'Turn off Page Breaks, we do this for speed .DisplayPageBreaks = False 'Set the first and last row to loop through Firstrow = .UsedRange.Cells(1).Row Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row 'We loop from Lastrow to Firstrow (bottom to top) For Lrow = Lastrow To Firstrow Step -1 'We check the values in the A column in this example With .Cells(Lrow, "B") If Not IsError(.Value) Then If Not IsNumeric(.Value) Or .Value = 0 Then If rng Is Nothing Then Set rng = .Cells Else Set rng = Application.Union(rng, .Cells) End If End If End If End With Next Lrow End With 'Delete all rows in one time If Not rng Is Nothing Then rng.EntireRow.Delete ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ScottMSP" wrote in message ... Hello, I am trying to modify Ron DeBruin's "Merge Cells from all or some worksheets into one Mastersheet" function but need to have a special condition inserted and I am not sure how to do it. I am not very good with VBA, but have had some success with modifying code. Specifically, I want to be able to copy data that appears in columns A - AH provided that column B has a value greater than zero. Currently I have in column B either; a 5 digit number, the word "Enter", or it is null. I only want to copy rows that have the five digital number (which is why I am thinking greater than zero). I have seven worksheets that I will be copying data from. I have pasted Ron's code below in the event it is an easy tweak. Thanks in advance. 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 = "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 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
How do you merge worksheets | Excel Worksheet Functions | |||
How can I merge two worksheets together | Excel Worksheet Functions | |||
Ron DeBruin's Sendmail | Excel Discussion (Misc queries) | |||
Merge Worksheets | Excel Discussion (Misc queries) | |||
Merge Worksheets | Excel Discussion (Misc queries) |