Copy Rows to sheet if column value >40, multiple sheets
Hi. I am very new to this and I assume I am needing macros rather than formula to complete this task.
basically I have 12 sheets of data, if column H (in any of these sheets & rows) has a currency value greater than 40;
I want to copy the entire row/s to Sheet16 named "Major" - which has the exact same columns and formatting.
I need this to be automatic.
What code do I need, where do I put the code? Thank you
Hello,
Try and see if this code helps. Add it to a regular module and run it.
thanks
Sub SumaryData() Dim sh As Worksheet Dim lrOrigen As Long Dim lrTarget As Long Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name <> "Major" Then lrOrigen = sh.Range("A1").CurrentRegion.Rows.Count lrTarget = Sheets("Major").Range("A1").CurrentRegion.Rows.Count + 1 'Filter the data sh.Range("A1").CurrentRegion.AutoFilter Field:=8, Criteria1:=">40" sh.Range("A1").CurrentRegion.Offset(1).Resize(lrOrigen - 1).Copy _ Destination:=Sheets("Major").Range("A" & lrTarget) 'clear the filters sh.Range("A1").CurrentRegion.AutoFilter End If Next Application.ScreenUpdating = False End Sub
Try this......
Sub transferdata() Dim ws As Worksheet Dim rng As Range, cell As Range Dim lr As Long, lr1 As Long Application.ScreenUpdating = False For Each ws In ActiveWorkbook.Sheets lr1 = Sheets("major").Cells(Rows.Count, "H").End(xlUp).Row If ws.Name <> "Major" Then lr = ws.Cells(Rows.Count, "H").End(xlUp).Row Set rng = ws.Range("H2:H" & lr) For Each cell In rng lr1 = lr1 + 1 If cell.Value > 40 Then cell.EntireRow.Copy Destination:=Sheets("Major").Range("A" & lr1) End If Next cell End If Next ws Sheets("Major").Activate Application.ScreenUpdating = True End Sub
Last edited by sktneer; 12-04-2013 at 12:30 AM.
Regards
sktneer
Treat people the way you want to be treated. Talk to people the way you want to be talked to.
Respect is earned NOT given.
Awesome, so do I add this to the Major sheet, or to each of sheets with data? right click on sheet, view code, paste? sorry i am still learning
You will have to add a module. Read this for more information. http://www.jlathamsite.com/Teach/Excel_GP_Code.htm
Also, if the macro is run twice, then the data just keeps being generated, rather than only adding new entries, is there a way around this? thanks again
Theres an error msg appearing, other than that its works really well :D
Sub SumaryData()
Dim sh As Worksheet
Dim lrOrigen As Long
Dim lrTarget As Long
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "Major Projects" Then
lrOrigen = sh.Range("A1").CurrentRegion.Rows.Count
lrTarget = Sheets("Major Projects").Range("A1").CurrentRegion.Rows.Count + 1
'Filter the data
sh.Range("A1").CurrentRegion.AutoFilter Field:=8, Criteria1:=">40000"
sh.Range("A1").CurrentRegion.Offset(1).Resize(lrOrigen - 1).Copy _
Destination:=Sheets("Major Projects").Range("A" & lrTarget)
'clear the filters
sh.Range("A1").CurrentRegion.AutoFilter
End If
Next
Application.ScreenUpdating = False
End Sub
Press Alt+F11 to open VBA window, then click on Insert--> Module and then paste the code given below in the opened VBA Code window. You are done.
The code given below will run only once i.e. if you run it repeatedly without adding new rows in any of your 16 sheets with a value >40 in col. H. So if you run this code twice by mistake it will not do the same action again.
Sub transferdata() Dim ws As Worksheet Dim rng As Range, cell As Range, rng1 As Range Dim lr As Long, lr1 As Long, lrcnt As Long, cnt As Long, m As Long, n As Long Application.ScreenUpdating = False For Each ws In ActiveWorkbook.Sheets If ws.Name <> "Major" Then lr = ws.Cells(Rows.Count, "H").End(xlUp).Row Set rng = ws.Range("H2:H" & lr) n = Application.WorksheetFunction.CountIf(rng, ">40") cnt = cnt + n End If Next ws lr1 = Sheets("Major").Cells(Rows.Count, "H").End(xlUp).Row Set rng1 = Sheets("Major").Range("H2:H" & lr1) m = Application.WorksheetFunction.CountIf(rng1, ">40") If m < cnt Then For Each ws In ActiveWorkbook.Sheets If ws.Name <> "Major" Then lr = ws.Cells(Rows.Count, "H").End(xlUp).Row Set rng = ws.Range("H2:H" & lr) For Each cell In rng lr1 = Sheets("major").Cells(Rows.Count, "H").End(xlUp).Row + 1 If cell.Value > 40 Then cell.EntireRow.Copy Destination:=Sheets("Major").Range("A" & lr1) End If Next cell End If Next ws End If Sheets("Major").Activate Application.ScreenUpdating = True End Sub
This code is great ! Thank you Sooo much!
quick question, how do I exclude it from pulling my Row ONE on each sheet, as to not add the headers ?
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks