HELP: display specific data on seperate sheets

  • Thread starter Thread starter Sam
  • Start date Start date
S

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
 
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
 
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
 
Back
Top