How to get information from string in a nice Excel table?

I have following code behind a button in Excel:

Sub Top10Names()
    Dim dataSheet As Worksheet
    Dim reportSheet As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim nameColumn As Range
    Dim dateColumn As Range
    Dim targetMonth As Long
    Dim targetYear As Long
    Dim i As Long
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Set dataSheet = ThisWorkbook.Sheets("TestSheet")
    Set reportSheet = ThisWorkbook.Sheets("Makro")
    
    lastRow = dataSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
    Dim columnF As Range
    Set columnF = dataSheet.Range("F6:F" & lastRow)
    
    Set dataRange = dataSheet.Range("A6:C" & lastRow)
    Set nameColumn = dataRange.Columns(3)
    Set dateColumn = dataRange.Columns(1)
    
    targetMonth = InputBox("Bitte geben Sie den Zielmonat ein (1-12):")
    targetYear = InputBox("Bitte geben Sie das Zieljahr ein:")
    
    For i = 1 To dataRange.Rows.Count
        If Month(dateColumn.Cells(i)) = targetMonth And Year(dateColumn.Cells(i)) = targetYear Then
            Namex = nameColumn.Cells(i)
            If dict.Exists(Namex) Then
                dict(Namex) = dict(Namex) + 1
            Else
                dict(Namex) = 1
            End If
        End If
    Next i
    
    
    reportSheet.Range("A1") = "Lieferant"
    reportSheet.Range("B1") = "Häufgkeit"
    reportSheet.Range("A2:B4") = ""
    reportSheet.Range("A1:B1").Interior.Color = vbBlack
    reportSheet.Range("A1:B1").Font.Color = vbWhite
    reportSheet.Range("C1") = "Grund"
    reportSheet.Range("C1").Interior.Color = vbBlack
    reportSheet.Range("C1").Font.Color = vbWhite

    
    For i = 0 To 9
        maxCount = 0
        For Each Key In dict.Keys()
            If dict(Key) > maxCount Then
                maxCount = dict(Key)
                maxKey = Key
            End If
        Next Key
        
        reportSheet.Cells(i + 2, 1) = maxKey
        reportSheet.Cells(i + 2, 2) = maxCount
        
       ' Find all rows in the data sheet where the name matches maxKey and the date is in the target month and year, and count the frequency of each reason from column F using a dictionary
    Dim reasons As Object
    Set reasons = CreateObject("Scripting.Dictionary")
    For j = 1 To dataRange.Rows.Count
        If nameColumn.Cells(j) = maxKey And Month(dateColumn.Cells(j)) = targetMonth And Year(dateColumn.Cells(j)) = targetYear Then
            reasonx = columnF.Cells(j)
            If reasons.Exists(reasonx) Then
                reasons(reasonx) = reasons(reasonx) + 1
            Else
                reasons(reasonx) = 1
            End If
        End If
    Next j
    
    ' Convert the dictionary of reasons and their frequencies into a list of strings
    Dim reasonList As String
    reasonList = ""
    For Each Key In reasons.Keys()
        reasonList = reasonList & Key & " (" & reasons(Key) & "), "
    Next Key
    
    ' Remove the trailing comma and space from the list of reasons
    If Len(reasonList) > 0 Then
        reasonList = left(reasonList, Len(reasonList) - 2)
    End If
    
    ' Write the list of reasons to the report sheet
    reportSheet.Cells(i + 2, 3) = reasonList
    
    dict.Remove (maxKey)
Next i
    
    
End Sub

The reasons are shown as a string with a number of how much they apear behind it.

I need to build a table, so that every reason is an extra item to every deliverer, with its number of apperiance in an extra cell, so I can work with it.

Tried to split them up but nothing worked out.

Instead of putting them into a String that you write into a single cell

Dim reasonList As String
reasonList = ""
For Each Key In reasons.Keys()
    reasonList = reasonList & Key & " (" & reasons(Key) & "), "
Next Key

use a 2-dimensional Array of type Variant (which reperesents a range) that you write into a range of cells:

Dim reasonList() As Variant
ReDim reasonList(1 To reasons.Count, 1 To 1)  ' create array with 1 column and x rows one for each reason

' fill that array with the reasons of your dictionary row by row
Dim k As Long
For k = 0 To reasons.Count - 1
    reasonList(k + 1, 1) = reasons.Keys()(k) & " (" & reasons.Items()(k) & ")"
Next k

Then you can output your array into a range:

Dim StartOutput As Range
Set StartOutput = reportSheet.Cells(i + 2, 3)

' we need to resize the start cell to the size of the array (otherwise data of the array will get lost)
StartOutput.Resize(Ubound(reasonList, 1), Ubound(reasonList, 2)).Value = reasonList

Just a note:

I recommend to use the Application.InputBox method and define the Argument Type:=1, so the user is forced to input a number and you don't run into errors:

targetMonth = Application.InputBox(Prompt:="Bitte geben Sie den Zielmonat ein (1-12):", Type:=1)
targetYear = Application.InputBox(Prompt:="Bitte geben Sie das Zieljahr ein:", Type:=1)

even better give the user the chance to press the cancel button, because if the user presses cancel now it just returns 0 as month and year.

Better approach with the input box:

Dim targetMonth As Long

Dim RetVal As Variant
RetVal = Application.InputBox(Prompt:="Bitte geben Sie den Zielmonat ein (1-12):", Type:=1)

If VarType(RetVal) = vbBoolean And RetVal = False Then
    Exit Sub  ' user pressed cancel so cancel the procedure
Else
    targetMonth = CLng(RetVal)
End If


Dim targetYear As Long

Dim RetVal As Variant
RetVal = Application.InputBox(Prompt:="Bitte geben Sie das Zieljahr ein:", Type:=1)

If VarType(RetVal) = vbBoolean And RetVal = False Then
    Exit Sub  ' user pressed cancel so cancel the procedure
Else
    targetYear = CLng(RetVal)
End If