Copying specific rows to another sheet

[Ravichandra Reddy]

I need to copy rows which have same information in column C into anothe
sheet.

For ex:

1 12 P
2 15 NP
3 20 AVG
4 25 NM
5 10 P
6 13 NP
7 16 P
8 12 NM
9 23 NP
10 35 NP

Now I need a macro so that in sheet 2 all rows which contains P shoul
be there, sheet 3 all rows which contain NP and so on.

Please help m

 

[Auric__]

I need to copy rows which have same information in column C into another
sheet.

For ex: [snip]
Now I need a macro so that in sheet 2 all rows which contains P should
be there, sheet 3 all rows which contain NP and so on.

Try this:

Sub foo()
Dim dataSheet As Worksheet
Dim avg As Worksheet, nm As Worksheet, np As Worksheet, p As Worksheet
Dim L0 As Long
'adjust names as appropriate
Set dataSheet = Worksheets("Sheet1")
Set avg = Worksheets("AVG")
Set nm = Worksheets("NM")
Set np = Worksheets("NP")
Set p = Worksheets("P")
For L0 = 1 To dataSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
dataSheet.Rows(L0).Copy
'for next line, change 2 to the appropriate column
Select Case dataSheet.Cells(L0, 2).Value
Case "AVG"
avg.Activate
avg.Cells(avg.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, _
1).Select
avg.Paste
Case "NM"
nm.Activate
nm.Cells(nm.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, _
1).Select
nm.Paste
Case "NP"
np.Activate
np.Cells(np.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, _
1).Select
np.Paste
Case "P"
p.Activate
p.Cells(p.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, _
1).Select
p.Paste
Case Else
'no match found; any necessary code here
End Select
Next
Application.CutCopyMode = False
End Sub

This assumes that there is already existing data on the other sheets, or a
header row or something. If not, add this to the end of the sub:

avg.Rows(1).Delete Shift:=xlUp
nm.Rows(1).Delete Shift:=xlUp
np.Rows(1).Delete Shift:=xlUp
p.Rows(1).Delete Shift:=xlUp

 

[Ben McClave]

Ravichandra,

It looks like Auric has a solution for you, but since I worked up one as well I thought I'd post it as well in case it helps out. The macro below uses autofilter to filter your range down to the unique values in the last column of data and then creates a sheet for each one. This means that if you later add a new value to the last column of data, then the macro will keep pace with it. The macro also assumes that your data has a header row and that it is a named range called "DataRange". See the macro comments to change these assumptions as applicable.

Hope this helps,
Ben

Sub NewSheets()
Dim wsData As Worksheet 'Worksheet with the Data
Dim rData As Range 'Range containing the data
Dim lCol As Long 'Column # to sort by
Dim x As Long '# of worksheets to create
Dim wsNew As Worksheet 'Temporary worksheet to filter the list
Dim wsDest(1 To 100) As Worksheet 'Destination worksheets

Application.ScreenUpdating = False
Set wsData = Sheet1 'thisworkbook.sheets("Sheet1")
'Note: rData must have a header row. You may use a named range (i.e. "DataRange") or _
a cell reference
Set rData = wsData.Range("DataRange") 'wsData.Range("A1:C11")
lCol = rData.Columns.Count 'Assumes we are filtering by last column, change as necessary
Set wsNew = ThisWorkbook.Worksheets.Add

'Create unique list of last column of data on a temporary worksheet
rData.Range(rData.Cells(1, lCol).Address).Copy wsNew.Range("A1")
rData.AdvancedFilter xlFilterCopy, , wsNew.Range("$A$1"), True

'Create a new sheet for each value
For x = 1 To wsNew.UsedRange.Rows.Count - 1
Set wsDest(x) = ThisWorkbook.Worksheets.Add
'Copy headers to new tab
rData.Range("1:1").Copy wsDest(x).Range("A1")
'Add criteria header to new tab
wsDest(x).Range(wsDest(x).Cells(1, lCol + 2).Address).Value =_
rData.Range(rData.Cells(1, lCol).Address).Value
'Add criteria value to new tab
wsDest(x).Range(wsDest(x).Cells(2, lCol + 2).Address).Value =wsNew.Range("A1").Offset(x, 0).Value
'Use advanced filter to copy the data into the new tab
rData.AdvancedFilter xlFilterCopy, wsDest(x).Range("E1:E2"), wsDest(x).Range(wsDest(x).Cells(1, 1).Address & ":" & _
wsDest(x).Cells(1, lCol).Address), False
On Error Resume Next
'Change tab name to criteria value, unless there is an error
wsDest(x).Name = wsNew.Range("A1").Offset(x, 0).Value
On Error GoTo 0
'Clear criteria
wsDest(x).Columns(lCol + 2).Clear
Next x
Application.DisplayAlerts = False
'Delete temporary worksheet
wsNew.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub