Add multiple items to scripting dictionary from one key and keep structure

You can use:

Sub Generate_List2()
   Dim i                           As Long
   Dim oDic                        As Object
   Dim vItems
   Dim vCriteria
   Dim vData

   Application.ScreenUpdating = False

   vCriteria = Sheets("Sheet1").Range("G1").Value2

   Set oDic = CreateObject("Scripting.Dictionary")
   With Sheets("Sheet1")
      vData = .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
   End With
   For i = 1 To UBound(vData, 1)
      If vData(i, 1) = vCriteria Then
         oDic.Item(CStr(vData(i, 2))) = Array(vData(i, 2), vData(i, 3))
      End If
   Next i
        If oDic.Count Then
           vItems = oDic.Items
             With Sheets("Sheet1").Range("F7").Resize(oDic.Count, 2)
             .Value = Application.Index(vItems, 0, 0)
                If Not Sheets("Sheet1").Range("F8").Value = "" Then
                    .Sort key1:=.Cells(1), Header:=xlNo
                End If
             End With
        End If
        
   Application.ScreenUpdating = True
   
End Sub