Tricky Transpose and Sort

First, thank you for looking and any assistance you can provide with this data problem. I have a very large spreadsheet consisting of thousands of rows. I need to transpose the data from columns to rows, but it needs to also sort the data into month/year categories. This may best be done in two separate steps. I have attached a file with two sheets. One is an example of the raw data and the second is the desired format. Any assistance is greatly appreciated.
Thank you

Hi

See how this goes.

Sub aaa()
  Dim WorkSH As Worksheet, DataSH As Worksheet, OutSH As Worksheet
  Set DataSH = Sheets("Raw Data")
  Set OutSH = Sheets("Sheet3")
  
  Set WorkSH = Sheets.Add
  WorkSH.Name = "Worksheet"
  
  DataSH.Activate
  OutSH.Range("A1:G1").Value = DataSH.Range("A1:G1").Value
  Range("J1").Value = "Date2"
  Range("J2").Formula = "=EOMONTH(H2,-1)+1"
  Range("J2").AutoFill Destination:=Range("J2:J" & Cells(Rows.Count, "H").End(xlUp).Row)
  
  DataSH.Range("J:J").AdvancedFilter action:=xlFilterCopy, copytorange:=WorkSH.Range("A1"), unique:=xlYes
  
  WorkSH.Range("A:A").Sort key1:=WorkSH.Range("A1"), order1:=xlAscending, header:=xlYes
  WorkSH.Range("A:A").Replace what:="#NUM!", replacement:=""
  With WorkSH
    .Range(.Range("A2"), .Range("A2").End(xlDown)).Copy
    OutSH.Range("H1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
  End With
  Application.DisplayAlerts = False
  WorkSH.Delete
  Application.DisplayAlerts = True
  
  For Each ce In Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row)
    If Not IsEmpty(ce) Then
      If Not IsEmpty(ce.Offset(0, -7)) Then
        outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        OutSH.Cells(outrow, 1).Resize(1, 7).Value = Cells(ce.Row, 1).Resize(1, 7).Value
      End If
      
      outcol = WorksheetFunction.Match(ce.Offset(0, 2), OutSH.Rows("1:1"), 0)
      OutSH.Cells(outrow, outcol).Value = ce.Offset(0, 1).Value
    End If
  
  Next ce
   
  DataSH.Range("J:J").ClearContents
  OutSH.Range("A1").CurrentRegion.EntireColumn.AutoFit
  With OutSH
    For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
      .Cells(i, 1).EntireRow.Insert shift:=xlDown
    Next i
  End With
End Sub

rylo