Best Approach to Do This Report

[homerl2409]

I am creating a reporting file where I want to add new sheets and add tables in these new sheets, using vba. As shown in the image below, there are two column Main Category and Sub Category. I want to create new sheet for every Main Category and add tables for every Sub Category based on the sheet it belongs to. Additionally I may add new entries to Main Category and Sub Category, the vba code should add sheet and tables for those as well.

So far I am able to add the new sheets , but couldn't add the tables , This is what I have:

Sub CreateSheetsFromAList()
Dim MyCell As Range, myRange As Range
        Dim MyCell1 As Range, myRange1 As Range
        Dim WSname AsString

        Sheet1.Select
        Range("A2").Select
        Range(ActiveCell, ActiveCell.End(xlDown)).Select
        Set myRange = Selection
        Application.ScreenUpdating =False

         ForEach MyCell In myRange
            If Len(MyCell.Text)>0Then
                'Check if sheet exists
                IfNot SheetExists(MyCell.Value)Then

                    'run new reports code until before Else

                    Sheets.Add After:=Sheets(Sheets.Count)'creates a new worksheet
                    Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet

                    WSname = MyCell.Value 'stores newly created sheetname to a string variable

                    'filters consolidated sheet based on newly created sheetname
                    Sheet3.Select
                    Range("A:T").AutoFilter
                    Range("D1").Select
                    Range("D1").AutoFilter Field:=4, Criteria1:=WSname, Operator:=xlFilterValues

                    Range("A1:U1").Select
                    lastRow = Cells(Rows.Count,1).End(xlUp).Row
                    Range("A1:U"& lastRow).Select
                    Selection.Copy 'copies filtered data

                    'search and activate WSname
                    ChooseSheet WSname

                    Range("AH2").Select
                    ActiveCell.PasteSpecial xlPasteValues

                    Range("AJ:AJ").Select
                    Selection.NumberFormat ="hh:mm"
                    Range("B2").Select
                 EndIf
            EndIf

        Next MyCell

        EndSub

         Function SheetExists(shtName AsString,Optional wb As Workbook)AsBoolean
        Dim sht As Worksheet

         If wb IsNothingThenSet wb = ThisWorkbook
         OnErrorResumeNext
         Set sht = wb.Sheets(shtName)
         OnErrorGoTo0
         SheetExists =Not sht IsNothing
         EndFunction

        Public Sub ChooseSheet(ByVal SheetName AsString)
        Sheets(SheetName).SelectEndSub

The result should look like this

What is the best approach in getting the above result? Please help