HELP: display specific data on seperate sheets

[Sam]

Hi All,

I have a Sheet with this kind of data:

ColumnA ColumnB Column C
Pam tree a asdf
Tom low b adf
Sam bree c adf
Pam tree d adf
Jim cree e agaad
Sam bree f adfgg
Pam tree g djg
Tom low h djhfh
Sam bree i ertr

How can I display Tom low's data only on Sheet2, Sam bree's data only on
Sheet3 and so on?

Thanks in advance

 

[Per Jessen]

Hi

Try this:

Sub SplitData()
Dim TargetRange As Range
Dim myArr()
Dim counter As Long

Set TargetSh = Worksheets("Sheet1")
Set TargetRange = TargetSh.Range("A1", TargetSh.Range("A" &
Rows.Count).End(xlUp))
TargetRange.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
UniqueNames = TargetRange.SpecialCells(xlCellTypeVisible).Cells.Count
ReDim myArr(UniqueNames - 1)
For Each cell In TargetRange.SpecialCells(xlCellTypeVisible)
myArr(counter) = cell.Value
counter = counter + 1
Next
ActiveSheet.ShowAllData
For sh = 1 To UBound(myArr)
Set DestSh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
DestSh.Name = myArr(sh)
TargetRange.AutoFilter field:=1, Criteria1:=myArr(sh)
TargetRange.SpecialCells(xlCellTypeVisible).EntireRow.Copy
DestSh.Range("A1")
TargetRange.AutoFilter
Next
End Sub

Regards,
Per

 

[john]

Morning Sam,
This code should do what you want. However, it is important that your header
names are unique if not, you may get unexpected results.

Place both procedure & function in standard module.

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 sheet name as required
Set ws1 = ThisWorkbook.Worksheets("Sheet1")

With ws1

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


Set rng = .Range("A1:C" & 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