Option Explicit
Public Sub PopulateTable(vYR As Variant, boolYR As Boolean)
Dim wsSource As Worksheet, wsOutput As Worksheet
Dim xlCalc As XlCalculation
Dim vNames As Variant, vPlaces As Variant, vData As Variant
Dim bList As Byte
Dim lngPlace As Long, lngName As Long, lngMaxProducts As Long
On Error GoTo Handler
With Application
    xlCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
Set wsSource = Sheets("Source")
Set wsOutput = Sheets("Output")
'Clear Existing Data
With wsOutput
    .Range(.Cells(4, "B"), .Cells(4, .Columns.Count)).ClearContents
    .Range(.Cells(5, "A"), .Cells(.Rows.Count, .Columns.Count)).ClearContents
End With
'Establish Unique Names / Places etc
With wsSource
    For bList = 1 To 2 Step 1
        With .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Offset(, Columns.Count - 2)
            .FormulaR1C1 = IIf(boolYR, "=REPT(RC1&"":""&RC" & IIf(bList = 1, 4, 3) & ",RC1=" & vYR & ")", "=RC" & IIf(bList = 1, 4, 3))
            With .Offset(, 1)
                .FormulaR1C1 = "=IF(COUNTIF(R1C[-1]:RC[-1],RC[-1])=1,RC" & IIf(bList = 1, 4, 3) & ",0)"
                .Value = .Value
                .SpecialCells(xlCellTypeConstants, xlNumbers).Delete
                .Sort Key1:=.Cells(1, 1), order1:=xlAscending
                Select Case Application.CountA(.Cells)
                    Case 1
                        vData = .Resize(1).Value
                    Case Is > 1
                        vData = Application.Transpose(.SpecialCells(xlCellTypeConstants, xlTextValues).Value)
                End Select
                If bList = 1 Then vNames = vData Else vPlaces = vData
                .Clear
            End With
            .Clear
        End With
    Next bList
    'List Unique Names
    With wsOutput.Cells(4, "B")
        Select Case VarType(vNames)
            Case 8
                .Value = vNames
            Case Else
                .Resize(, UBound(vNames)).Value = vNames
        End Select
    End With
    'List Unique Places
    With wsOutput.Cells(5, "A")
        Select Case VarType(vPlaces)
            Case 8
                .Value = vPlaces
            Case Else
                .Resize(UBound(vPlaces)).Value = Application.Transpose(vPlaces)
        End Select
    End With
    'Revise Places / Names (so always UBound) & Subsequently Iterate - Applying Filters - Retrieving Data
    With wsOutput
        vPlaces = Application.Transpose(.Range(.Cells(4, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value)
        vNames = Application.Transpose(.Range(.Cells(4, "A"), .Cells(4, .Columns.Count).End(xlToLeft)).Value)
        .Range(Cells(5, "A"), Cells(.Rows.Count, "A")).ClearContents
        With Range("_Data")
            If boolYR Then .AutoFilter Field:=1, Criteria1:=vYR
            For lngPlace = 2 To UBound(vPlaces) Step 1
                wsOutput.Cells(Rows.Count, "A").End(xlUp).Offset(Application.Max(1, lngMaxProducts)).Value = vPlaces(lngPlace)
                lngMaxProducts = 0
                .AutoFilter Field:=3, Criteria1:=vPlaces(lngPlace)
                For lngName = 2 To UBound(vNames, 1) Step 1
                    .AutoFilter Field:=4, Criteria1:=vNames(lngName, 1)
                    On Error Resume Next
                    With .Offset(1).Columns(5).SpecialCells(xlCellTypeVisible)
                        .Copy Destination:=wsOutput.Cells(wsOutput.Cells(Rows.Count, "A").End(xlUp).Row, lngName)
                        lngMaxProducts = Application.Max(lngMaxProducts, .Cells.Count - 1)
                    End With
                    On Error GoTo Handler
                Next lngName
            Next lngPlace
        End With
    End With
End With

ExitPoint:
Range("_Data").AutoFilter
Set wsSource = Nothing
Set wsOutput = Nothing
With Application
    .Calculation = xlCalc
    .ScreenUpdating = True
    .EnableEvents = True
End With

Exit Sub

Handler:
MsgBox "Error Has Occurred" & vbLf & vbLf & _
        "Error Number: " & Err.Number & vbLf & vbLf & _
        "Error Desc.: " & Err.Description, _
        vbCritical, _
        "Fatal Error"
Resume ExitPoint

End Sub