Split action types into different sheets - vba

Question

Hi I have a excel sheet with different action types such as dividends, annual general meetings and so on..
Is there a way to write a vba macro that takes all the action types and puts them into separate sheet within the workbook ? Also the header such as date time should be included in all of the sheets. I am kind of struggling with this atm as I am new to VBA: I have a screen shot of the excel sheet..
Again thanks in advance.
I have the code which sorts for dividends however I am struggling to get the actions into a list and then go through the list and create new sheets.
Sub SortActions()
Dim i&, k&, s$, v, r As Range, ws As Worksheet
Set r = [index(a:a,match("###start",a:a,),):index(a:a,match("###end",a:a,),)].Offset(, 6)
k = r.Row - 1
v = r
For i = 1 To UBound(v)
If LCase$(v(i, 1)) = "dividend" Then
s = s & ", " & i + k & ":" & i + k
End If
Next
s = Mid$(s, 3)
If Len(s) Then
Set ws = ActiveSheet
With Sheets.Add(, ws)
ws.Range(s).Copy .[a1]
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("20140701_corporate_action_servi").Select
Rows("2:2").Select
Selection.Copy2
Range("C32").Select
Sheets("Sheet11").Select
ActiveSheet.Paste
End With
End If
End Sub

Answer 1

This should do it:
Public Sub CopyActionTypes()
Dim i&, k&, key, v, r As Range, ws As Worksheet, d As Object
On Error Resume Next
Set r = [index(a:a,match("###start",a:a,),):index(a:a,match("###end",a:a,),)].Offset(, 6)
If Err = 0 Then
On Error GoTo 0
k = r.Row + 1
v = r
Set d = CreateObject("scripting.dictionary")
d.CompareMode = 1
For i = 1 To UBound(v)
key = v(i, 1)
If Len(key) Then
If Not d.Exists(key) Then d.Add key, k & ":" & k
d(key) = d(key) & Replace(",.:.", ".", i)
End If
Next
Set ws = ActiveSheet
For Each key In d.Keys
If LCase$(key) <> "action_type" Then
With Sheets.Add(, ws.Parent.Sheets(ws.Parent.Sheets.Count))
.Name = key
GetRangeUnion(d(key), ws).Copy .[a1]
End With
End If
Next
End If
End Sub
Private Function GetRangeUnion(s As String, ws As Worksheet) As Range
Dim i&, v, r As Range
v = Split(s, ",")
Set r = ws.Range(v(0))
For i = 1 To UBound(v)
Set r = Union(r, ws.Range(v(i)))
Next
Set GetRangeUnion = r
End Function
As an aside, try to not select anything from code during your macros. This is a best practice and one of many ways to optimize code.