copy to new worksheet

[Rachel]

Help on a macro code please.

Have a worksheet such as below:

A B C D
GLASS 1 YES DONE
CUP 2 NO IN PROGRESS
CHAIR 3 NO DONE
CUP 4 NO IN PROGRESS
GLASS 5 YES DONE

I want to have a macro to copy the entire row to a new worksheet such that
if COLUMN A contains the word "GLASS" it will copy the entire row to
worksheet named "GLASS" and "CUP" to a new worksheet named "CUP" and so on
and so fort... can this be done? THANKS!

 

[Don Guillett]

I would use data>filter>autofilter>filter on glass>copy/paste. Record a
macro and clean it up.
For glass you say to an existing? sheet and cup to a NEW? sheet???

 

[muddan madhu]

try this

Sub copy_it()

Dim i As Integer, rng1 As Integer, rng As Integer

acn = ActiveSheet.Name
rng = cells(Rows.Count, "A").End(xlUp).Row

For i = 1 To rng
cells(i, "A").Select
ActiveCell.EntireRow.Copy
Sheets(cells(i, "A").Value).Select
rng1 = cells(Rows.Count, "A").End(xlUp).Row + 1
cells(rng1, "A").Select
ActiveSheet.Paste
Sheets(acn).Activate
Next
Application.CutCopyMode = False

End Sub

 

[Rachel]

HI Don,

Thanks for this but i dont really know how to record a macro
What I mean is that it copies each values in column A to a worsheet named
after that values. i.e GLASS to worksheet "GLASS" and CUP to worksheet "CUP"
et al. THANKS!

 

[john]

Rachel,
I think this code will do what you want - Paste both the procedure &
function in a standard module. The worksheet which stores your data must have
Column headings otherwise code may fail.

Sub FilterDataToSheets()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim lr As Integer
Dim c As Range

'worksheet where your data is stored
'change Sheet1 name as required
Set ws1 = ThisWorkbook.Worksheets("Sheet1")

With ws1

lr = .Cells(.Rows.Count, "A").End(xlUp).Row


Set rng = .Range("A1" & lr)

'extract list
.Columns("A:A").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("J1"), Unique:=True

lr = .Cells(.Rows.Count, "J").End(xlUp).Row

'set up Criteria Area
.Range("L1").Value = .Range("A1").Value

For Each c In .Range("J2:J" & lr)
'add the name to the criteria area
.Range("L2").Value = c.Value

'sheet aleady exists
If SheetExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If


Next

.Select
.Columns("J:L").Delete

End With
End Sub

Function SheetExists(wksName As String) As Boolean
On Error Resume Next
SheetExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function



jb

 

[Ron de Bruin]

Hi Rachel

See
http://www.rondebruin.nl/copy5.htm