Copy specific data form sheets into master sheet
in [Functions]
|
Prev: conditional Formatting cell wildcard
Next: Complex conditional summing - array COUNT works, array SUM gives #VALUE
From: Eva on 18 Nov 2009 17:08 Hi RyGuy Thank you for your code. I got distracted today and had to do something else, but I am going to test it tomorrow and I will let you know how it will work. -- Greatly appreciated Eva "RyGuy" wrote: > I'll try to make this simple (and short; am tired now). > > Create a sheet named 'SummarySheet2'. > > Add a button on any sheet. Link the button to Macro1(in module1): > Sub Macro1() > Dim sh As Worksheet > Dim DestSh As Worksheet > Dim Last As Long > Dim shLast As Long > Dim CopyRng As Range > Dim StartRow As Long > > With Application > .ScreenUpdating = False > .EnableEvents = False > End With > > 'Delete the sheet "RDBMergeSheet" if it exist > Application.DisplayAlerts = False > On Error Resume Next > ActiveWorkbook.Worksheets("SummarySheet1").Delete > On Error GoTo 0 > Application.DisplayAlerts = True > > 'Add a worksheet with the name "RDBMergeSheet" > Set DestSh = ActiveWorkbook.Worksheets.Add > DestSh.Name = "SummarySheet1" > > 'Fill in the start row > StartRow = 2 > > '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 and sh > Last = LastRow(DestSh) > shLast = LastRow(sh) > > 'If sh is not empty and if the last row >= StartRow copy the > CopyRng > If shLast > 0 And shLast >= StartRow Then > > 'Set the range that you want to copy > Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast)) > > '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 below example 1 on > this page > CopyRng.Copy > With DestSh.Cells(Last + 1, "A") > .PasteSpecial xlPasteValues > .PasteSpecial xlPasteFormats > Application.CutCopyMode = False > End With > > End If > > 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 > > > Add a button...ON SHEET NAMED 'SummarySheet1'. > Link the button to Macro2 (in module2); > Sub Macro2() > 'Note: This macro use the function LastRow > Dim My_Range As Range > Dim DestSh As Worksheet > Dim CalcMode As Long > Dim ViewMode As Long > Dim FilterCriteria As String > Dim CCount As Long > Dim rng As Range > > Set My_Range = Range("A1:AZ" & LastRow(ActiveSheet)) > My_Range.Parent.Select > > Set DestSh = Sheets("SummarySheet2") > > If ActiveWorkbook.ProtectStructure = True Or _ > My_Range.Parent.ProtectContents = True Then > MsgBox "Sorry, not working when the workbook or worksheet is > protected", _ > vbOKOnly, "Copy to new worksheet" > Exit Sub > End If > > 'Change ScreenUpdating, Calculation, EnableEvents, .... > With Application > CalcMode = .Calculation > .Calculation = xlCalculationManual > .ScreenUpdating = False > .EnableEvents = False > End With > ViewMode = ActiveWindow.View > ActiveWindow.View = xlNormalView > ActiveSheet.DisplayPageBreaks = False > > 'Firstly, remove the AutoFilter > My_Range.Parent.AutoFilterMode = False > > My_Range.AutoFilter Field:=1, Criteria1:="=Summary by Customer > Category*" _ > , Operator:=xlAnd, Criteria2:="=*TOTAL STATEMENT" > > CCount = 0 > On Error Resume Next > CCount = > My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count > On Error GoTo 0 > If CCount = 0 Then > MsgBox "There are more than 8192 areas:" _ > & vbNewLine & "It is not possible to copy the visible data." _ > & vbNewLine & "Tip: Sort your data before you use this macro.", _ > vbOKOnly, "Copy to worksheet" > Else > 'Copy the visible data and use PasteSpecial to paste to the Destsh > With My_Range.Parent.AutoFilter.Range > On Error Resume Next > ' Set rng to the visible cells in My_Range without the header row > Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _ > .SpecialCells(xlCellTypeVisible) > On Error GoTo 0 > If Not rng Is Nothing Then > 'Copy and paste the cells into DestSh below the existing data > rng.Copy > With DestSh.Range("A" & LastRow(DestSh) + 1) > ' Paste:=8 will copy the columnwidth in Excel 2000 and > higher > ' Remove this line if you use Excel 97 > .PasteSpecial Paste:=8 > .PasteSpecial xlPasteValues > .PasteSpecial xlPasteFormats > Application.CutCopyMode = False > End With > 'Delete the rows in the My_Range.Parent worksheet > 'rng.EntireRow.Delete > End If > End With > End If > > 'Close AutoFilter > My_Range.Parent.AutoFilterMode = False > > 'Restore ScreenUpdating, Calculation, EnableEvents, .... > ActiveWindow.View = ViewMode > Application.Goto DestSh.Range("A1") > With Application > .ScreenUpdating = True > .EnableEvents = True > .Calculation = CalcMode > 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:=xlValues, _ > SearchOrder:=xlByRows, _ > SearchDirection:=xlPrevious, _ > MatchCase:=False).Row > On Error GoTo 0 > End Function > > > That should work fine. If you still have problems, post back, with specific > details of what happens. > > HTH, > Ryan-- > > > "Ron de Bruin" wrote: > > > See > > http://www.rondebruin.nl/copy2.htm > > > > -- > > > > Regards Ron de Bruin > > http://www.rondebruin.nl/tips.htm > > > > > > "Eva" <Eva(a)discussions.microsoft.com> wrote in message news:600AC4B1-3D1A-4F86-8FF0-7C8AA88AC215(a)microsoft.com... > > > Hi > > > Thank you for your response, but it is not exactly what I want. There are > > > about 20 sheets and I was thinking about the macro, that copy the same > > > section in all sheets and paste it into master sheet. > > > -- > > > Greatly appreciated > > > Eva > > > > > > > > > "ryguy7272" wrote: > > > > > >> Data > Filter > Auto Filter > > >> > > >> Custom > > >> > > >> Items Begin With...Summary by Customer Category > > >> And > > >> Items End with...TOTAL > > >> > > >> HTH, > > >> Ryan--- > > >> > > >> -- > > >> Ryan--- > > >> If this information was helpful, please indicate this by clicking ''Yes''. > > >> > > >> > > >> "Eva" wrote: > > >> > > >> > Hi > > >> > I have number of sheets with some data. In all of them there is a sequence > > >> > of data starting:"Summary by Customer Category" and it ends :"TOTAL > > >> > STATEMENT". > > >> > It can be found in column A. > > >> > How I can copy this data from all of sheets and paste it into master sheet? > > >> > > > >> > -- > > >> > Greatly appreciated > > >> > Eva > > . > >
From: Eva on 20 Nov 2009 13:06
Hi I tested both macros. The first one works fine - it copies all data to one sheet called SummarySheet1. The second one doesn't work and I stepped into to see what is not working properly. When it gets to My_Range.AutoFilter Field:=1, Criteria1:="=Summary by Customer Category*" _ , Operator:=xlAnd, Criteria2:="=*TOTAL STATEMENT" Filters blank rows. I don't understand VB so well to fix it, so if you have a time please have a look at this. I really appreciate your help Eva "RyGuy" wrote: > I'll try to make this simple (and short; am tired now). > > Create a sheet named 'SummarySheet2'. > > Add a button on any sheet. Link the button to Macro1(in module1): > Sub Macro1() > Dim sh As Worksheet > Dim DestSh As Worksheet > Dim Last As Long > Dim shLast As Long > Dim CopyRng As Range > Dim StartRow As Long > > With Application > .ScreenUpdating = False > .EnableEvents = False > End With > > 'Delete the sheet "RDBMergeSheet" if it exist > Application.DisplayAlerts = False > On Error Resume Next > ActiveWorkbook.Worksheets("SummarySheet1").Delete > On Error GoTo 0 > Application.DisplayAlerts = True > > 'Add a worksheet with the name "RDBMergeSheet" > Set DestSh = ActiveWorkbook.Worksheets.Add > DestSh.Name = "SummarySheet1" > > 'Fill in the start row > StartRow = 2 > > '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 and sh > Last = LastRow(DestSh) > shLast = LastRow(sh) > > 'If sh is not empty and if the last row >= StartRow copy the > CopyRng > If shLast > 0 And shLast >= StartRow Then > > 'Set the range that you want to copy > Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast)) > > '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 below example 1 on > this page > CopyRng.Copy > With DestSh.Cells(Last + 1, "A") > .PasteSpecial xlPasteValues > .PasteSpecial xlPasteFormats > Application.CutCopyMode = False > End With > > End If > > 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 > > > Add a button...ON SHEET NAMED 'SummarySheet1'. > Link the button to Macro2 (in module2); > Sub Macro2() > 'Note: This macro use the function LastRow > Dim My_Range As Range > Dim DestSh As Worksheet > Dim CalcMode As Long > Dim ViewMode As Long > Dim FilterCriteria As String > Dim CCount As Long > Dim rng As Range > > Set My_Range = Range("A1:AZ" & LastRow(ActiveSheet)) > My_Range.Parent.Select > > Set DestSh = Sheets("SummarySheet2") > > If ActiveWorkbook.ProtectStructure = True Or _ > My_Range.Parent.ProtectContents = True Then > MsgBox "Sorry, not working when the workbook or worksheet is > protected", _ > vbOKOnly, "Copy to new worksheet" > Exit Sub > End If > > 'Change ScreenUpdating, Calculation, EnableEvents, .... > With Application > CalcMode = .Calculation > .Calculation = xlCalculationManual > .ScreenUpdating = False > .EnableEvents = False > End With > ViewMode = ActiveWindow.View > ActiveWindow.View = xlNormalView > ActiveSheet.DisplayPageBreaks = False > > 'Firstly, remove the AutoFilter > My_Range.Parent.AutoFilterMode = False > > My_Range.AutoFilter Field:=1, Criteria1:="=Summary by Customer > Category*" _ > , Operator:=xlAnd, Criteria2:="=*TOTAL STATEMENT" > > CCount = 0 > On Error Resume Next > CCount = > My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count > On Error GoTo 0 > If CCount = 0 Then > MsgBox "There are more than 8192 areas:" _ > & vbNewLine & "It is not possible to copy the visible data." _ > & vbNewLine & "Tip: Sort your data before you use this macro.", _ > vbOKOnly, "Copy to worksheet" > Else > 'Copy the visible data and use PasteSpecial to paste to the Destsh > With My_Range.Parent.AutoFilter.Range > On Error Resume Next > ' Set rng to the visible cells in My_Range without the header row > Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _ > .SpecialCells(xlCellTypeVisible) > On Error GoTo 0 > If Not rng Is Nothing Then > 'Copy and paste the cells into DestSh below the existing data > rng.Copy > With DestSh.Range("A" & LastRow(DestSh) + 1) > ' Paste:=8 will copy the columnwidth in Excel 2000 and > higher > ' Remove this line if you use Excel 97 > .PasteSpecial Paste:=8 > .PasteSpecial xlPasteValues > .PasteSpecial xlPasteFormats > Application.CutCopyMode = False > End With > 'Delete the rows in the My_Range.Parent worksheet > 'rng.EntireRow.Delete > End If > End With > End If > > 'Close AutoFilter > My_Range.Parent.AutoFilterMode = False > > 'Restore ScreenUpdating, Calculation, EnableEvents, .... > ActiveWindow.View = ViewMode > Application.Goto DestSh.Range("A1") > With Application > .ScreenUpdating = True > .EnableEvents = True > .Calculation = CalcMode > 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:=xlValues, _ > SearchOrder:=xlByRows, _ > SearchDirection:=xlPrevious, _ > MatchCase:=False).Row > On Error GoTo 0 > End Function > > > That should work fine. If you still have problems, post back, with specific > details of what happens. > > HTH, > Ryan-- > > > "Ron de Bruin" wrote: > > > See > > http://www.rondebruin.nl/copy2.htm > > > > -- > > > > Regards Ron de Bruin > > http://www.rondebruin.nl/tips.htm > > > > > > "Eva" <Eva(a)discussions.microsoft.com> wrote in message news:600AC4B1-3D1A-4F86-8FF0-7C8AA88AC215(a)microsoft.com... > > > Hi > > > Thank you for your response, but it is not exactly what I want. There are > > > about 20 sheets and I was thinking about the macro, that copy the same > > > section in all sheets and paste it into master sheet. > > > -- > > > Greatly appreciated > > > Eva > > > > > > > > > "ryguy7272" wrote: > > > > > >> Data > Filter > Auto Filter > > >> > > >> Custom > > >> > > >> Items Begin With...Summary by Customer Category > > >> And > > >> Items End with...TOTAL > > >> > > >> HTH, > > >> Ryan--- > > >> > > >> -- > > >> Ryan--- > > >> If this information was helpful, please indicate this by clicking ''Yes''. > > >> > > >> > > >> "Eva" wrote: > > >> > > >> > Hi > > >> > I have number of sheets with some data. In all of them there is a sequence > > >> > of data starting:"Summary by Customer Category" and it ends :"TOTAL > > >> > STATEMENT". > > >> > It can be found in column A. > > >> > How I can copy this data from all of sheets and paste it into master sheet? > > >> > > > >> > -- > > >> > Greatly appreciated > > >> > Eva > > . > > |