VBA: Array & countif

Add some helper columns in (You can hide these later if you wish)

In Cell D2 the formula is =MONTH(C2), Cell E2 is =YEAR(C2) and the same for G and H but on column F

Then in your result table I've used the formula

=COUNTIFS($B$2:$B$4,$A8, $D$2:$D$4,MONTH(B$7),$E$2:$E$4,YEAR(B$7))

For Activity A, the same formula can be used for Activity B (But using columns G and H instead of D and E to get your results. No need for VBA

Update with vba approach

You can also try this VBA approach. You'll need to pay attention to the comments in all caps and update for your input and output. The code will take your input array and assume everything after column 2 is an Activity Date. It will then compile the results and write back to the sheet. This can work on any range of dates as it'll auto detect the first and last date (populating all dates in the year) and also any number of activities. There's a lot of loops going on here due to the flexibility of it all, but as it's all being handled in arrays/dictionaries (i.e. in memory) you shouldn't get a performance issue. You could probably do it in fewer but this should handle it in seconds no matter the data set size so gain over effort really isn't worth it.

Option Explicit
Public Sub GenerateResults()
    Dim arr As Variant, tmp As Variant, Dates() As Double, Results As Object
    Dim i As Long, j As Long, StartRow As Long, ResultsSeparator As Long
    Dim StartYear As Long, EndYear As Long, yr As Long, mo As Long
    Dim c

    ' ******UPDATE TO POINT AT YOUR ARRAY******
    With Sheet1
        arr = Range(.Cells(1, 1), .Cells(4, 5)).Value2
    End With

    Set Results = CreateObject("Scripting.Dictionary")

    For j = 3 To UBound(arr, 2)
        If StartYear < Format(WorksheetFunction.Min(Application.Index(arr, 0, j)), "yyyy") Then
             StartYear = Format(WorksheetFunction.Min(Application.Index(arr, 0, j)), "yyyy")
        End If
        If EndYear < Format(WorksheetFunction.Max(Application.Index(arr, 0, j)), "yyyy") Then
            EndYear = Format(WorksheetFunction.Max(Application.Index(arr, 0, j)), "yyyy")
        End If
    Next j

    ' 1 to 12 for months in the year, 1 to 2 for each activitity. This could be adapated for more then 12 months
    ReDim Dates(1 To (1 + EndYear - StartYear) * 12, 1 To UBound(arr, 2) - 2)

    For i = LBound(arr) To UBound(arr)
        Set tmp = Nothing
        ' Add to dictionary if colour not in array
        If Not Results.exists(arr(i, 2)) Then Results.Add Key:=arr(i, 2), Item:=Dates
        ' Assign your data to a temporary array so we can change it
        tmp = Results(arr(i, 2))
        ' Update data with activity dates
        For j = LBound(Dates, 2) To UBound(Dates, 2)
            tmp(12 * (Year(arr(i, 2 + j)) - StartYear) + Month(arr(i, 2 + j)), j) = tmp(12 * (Year(arr(i, 2 + j)) - StartYear) + Month(arr(i, 2 + j)), j) + 1
        Next j
        ' Write data back to dictionary
        Results(arr(i, 2)) = tmp
    Next i

    Application.ScreenUpdating = False
    ' ******CHANGE TO WHERE YOUR WANT YOUR RESULTS******
    ' Starting row of results (change to your output)
    StartRow = 7
    ' How many rows do you want between Activity A and B etc.
    ResultsSeparator = 3

    With Sheet1
        For j = LBound(Dates, 2) To UBound(Dates, 2)
            With .Cells(StartRow + (j - 1) * (ResultsSeparator + Results.Count), 1)
                .Value2 = UCase("Activity " & Split(.Cells(1, j).Address, "$")(1))
                .Font.Bold = True
            End With
        Next j
        StartRow = StartRow + 1
        For j = LBound(Dates, 1) To UBound(Dates, 1)
            yr = StartYear + IIf(j Mod 12 = 0, (j / 12) - 1, WorksheetFunction.RoundDown(j / 12, 0))
            mo = IIf(j > 12, j - 12 * IIf(j Mod 12 = 0, (j / 12) - 1, WorksheetFunction.RoundDown(j / 12, 0)), j)
            For i = LBound(Dates, 2) To UBound(Dates, 2)
                With .Cells(StartRow + (i - 1) * (ResultsSeparator + Results.Count), 1 + j)
                    .Value2 = DateSerial(yr, mo, 1)
                    .NumberFormat = "mmm-yy"
                End With
            Next i
        Next j
        StartRow = StartRow + 1
        ' Loop through dictionary
        For Each c In Results.keys
            ' Write back results for Activity A
            For j = LBound(Dates, 2) To UBound(Dates, 2)
                With .Cells(StartRow + (j - 1) * (ResultsSeparator + Results.Count), 1)
                    .Value2 = c
                    Range(.Offset(0, 1), .Offset(0, UBound(Results(c), 1))) = Application.Transpose(Application.Index(Results(c), 0, j))
                End With
            Next j
            ' Increase Row
            StartRow = StartRow + 1
        Next c
    End With
    Application.ScreenUpdating = True
End Sub