Macro to create worksheets from data in Cells

[bobster99]

I am looking for a macro to copy rows from a spreadsheet and create separate worksheets based on data in Column O keeping the original spreadsheet intact.

Data in Column O isn't sorted and changes almost daily so I can't hard code anything.

Ex.

[TABLE="class: grid, width: 442"]
<tbody>[TR]
[TD]1[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]N[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Defect #[/TD]
[TD]Severity[/TD]
[TD]Detailed Description[/TD]
[TD]Target Date for Resolution[/TD]
[TD]Date Last Update[/TD]
[TD]Awaiting Response From[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]1[/TD]
[TD]3[/TD]
[TD]Information Not Populating[/TD]
[TD]6/30/2017[/TD]
[TD]Closed[/TD]
[TD]Closed[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]2[/TD]
[TD]4[/TD]
[TD]Information Not Populating[/TD]
[TD]7/1/2017[/TD]
[TD]7/1[/TD]
[TD]George[/TD]
[/TR]
</tbody><colgroup><col><col span="2"><col><col><col span="2"></colgroup>[/TABLE]

In this example I would like the original sheet and two additional sheets, one "Closed" and one "George" with the associated rows copied to Sheets "Closed" and "George".

I have tried my best to do this but sadly all of my attempts have ended in failure.

Can someone with much more knowledge than I have give me a hand?

Thanks
Bob

 

[bobster99]

Found this after a bit more searching...

I would thank the creator but somehow he got banned.

Thanks for looking.

Sub columntosheets()

Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh

Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate

End Sub