Solved: How can i copy rows to new sheet based on critera

[romeo]

Hello, can someone help me to write Vb code to extract rows of data from a range based on a critera for each cell in a row.

Ok, the problem is I have a table of data about 150 rows and 10 columns. I would like to copy each row that contains a cell with the number say 5 or 6 or 7 or 8 to worksheets 5, 6, 7 and 8 respectively. Also since a row may contain 7 and 5 as well therefore that same row will be copied to sheet 7 and 5. I would like if these sheets could automatically updated each time a row of data is entered into the table. Below is example of the table. I know this may not be easy, so thanks in advance.
There is an example of the data attatch. again thanks for your help.

[mdmackillop]

Hi Romeo
Welcome to VBAX
This is not too difficult but a couple of questions.
Is your data in specific columns? eg D, G & J
How will you enter your criteria, from a range of cells or via an input box?
What are the actual sheet names that you want the rows copied to? 5, 6 or Sheet5, Sheet6?

[romeo]

Thanks for your interest mdmackkillop. i have updated my post with an attatchment so u should be able to have a clearer view of what my table look like and what i am hoping to get from the code.

[mdmackillop]

Hi Romeo,
For a "clearer view", could you answer my questions?

[romeo]

I would prefer if the criteria written in the code. it is from 1 to 60. any cell found with such number the entire row will be copy and past on a sheet called that number example Sheet20 for all the cells containing 20. I normally enter the table data into the cells from left to right just plain and simple like that. I am more interested in getting the sheets updated atomically. thanks Mdmacklillop

[romeo]

ok. i think i understand your question now. The data con be found in colum c f and i

[mdmackillop]

The numbers from 1 to 60 do not appear in columns C, F or I

[romeo]

sorry its colum d g j. its all about the score. score one two and three. thanks

[mdmackillop]

Rename your Sheet1 to "Scores"
Sub SortScores()
Dim a As Long, sh As Worksheet, c As Range, FirstAddress As String
Application.ScreenUpdating = False
For a = 1 To 60
With Worksheets("Scores").Range("D:D,G:G,J:J")
Set c = .Find(a, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
On Error Resume Next
Set sh = Sheets("Sheet" & a)
If Err.Number <> 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Sheet" & a
End If
c.EntireRow.Copy Sheets("Sheet" & a).Cells(Rows.Count, _
2).End(xlUp).Offset(1, -1)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next
Sheets("Scores").Activate
Application.ScreenUpdating = True
End Sub

[mdmackillop]

The following will allocate scores from the last row.

Sub SortLineScore()
Dim a As Long, sh As Worksheet, c As Range, FirstAddress As String
Dim Rw As Long
Application.ScreenUpdating = False
Rw = Cells(Rows.Count, 2).End(xlUp).Row
For a = 1 To 60
With Worksheets("Scores").Application.Union(Cells(Rw, "D"), _
Cells(Rw, "G"), Cells(Rw, "J"))
Set c = .Find(a, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
On Error Resume Next
Set sh = Sheets("Sheet" & a)
If Err.Number <> 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Sheet" & a
End If
c.EntireRow.Copy Sheets("Sheet" & a).Cells(Rows.Count, _
2).End(xlUp).Offset(1, -1)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next
Sheets("Scores").Activate
Application.ScreenUpdating = True

End Sub

[romeo]

mdmackillop. i can tell u this that code runs excellent. couldnt be better. and it is even faster than i thought i would be. You are SUPERMAN. i didnt have a clue that i would get this far. thank u so much mdmackillop

[mdmackillop]

Re your PM, I'm posting a sample

Sub SortScores()
Dim a As Long, sh As Worksheet, c As Range, FirstAddress As String
Dim Ws As Worksheet, i As Long
Dim Rng As Range, Chk As Range
Application.ScreenUpdating = False
Set Ws = Sheets("Scores")
'Loop through scores
For a = 1 To 60
'Look in columns for vales
With Ws.Range("D:D,G:G,J:J")
Set c = .Find(a, LookIn:=xlValues, After:=[D1], LookAt:=xlWhole)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
'If sheet "a" does not exist then add it
On Error Resume Next
Set sh = Sheets("Sheet" & a)
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
With ActiveSheet
.Columns(2).ColumnWidth = 20
.Name = "Sheet" & a
Ws.Range("B3:K3").Copy .Range("B2")
End With
End If
'Return to Scores sheet
Ws.Activate
'Set range to be copied
Set Rng = Ws.Cells(c.Row, 2).Range("A1:J1")
'Look in target sheet column B for date in range
Set Chk = Sheets("Sheet" & a).Range("B:B").Find(What:=Rng(1), _
LookIn:=xlFormulas)
If Chk Is Nothing Then
Rng.Copy Sheets("Sheet" & a).Cells(Rows.Count, 2).End(xlUp).Offset(1)
End If
'Find next a
Set c = .Find(a, LookIn:=xlValues, LookAt:=xlWhole, After:=c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next
'Sort results
For i = 1 To Sheets.Count
Sheets("Sheet" & i).Activate
Range([B2], [B2].End(xlDown).End(xlToRight)).Sort _
Key1:=Range("B2"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, Orientation:=xlTopToBottom
Next
Ws.Activate
Application.ScreenUpdating = True
End Sub

[romeo]

Yeah i can see. its still adding duplicate data if the code run twice. I am thinking if a code should be place on the generated sheets to remove any duplicate rows if that will work?? emm i dont know. thanks for your effort mdmackillop

[mdmackillop]

Hi Romeo,
I've amended and reposted a new sample above which resolves the duplication issue (Thanks to Johnske)
Regards
MD