Transferring part of a large array to smaller array

Good day,
I'm trying to transfer a part of a large array to a smaller array and then put it to a spreadsheet range, but it is not working for me.
Here is the code:

'This code does not work.
Sub Mcr_ii()
    Dim x As Variant
    Dim y As Variant
    Dim r As Long, c As Long
    Dim rCel As Integer: rCel = 1
    Dim lRow As Long: lRow = Sheets("DBase").Cells(Rows.Count, 1).End(xlUp).Row
    Dim iCount As Long
    iCount = Application.CountIf(Sheets("DBase").Range("E:E"), "B")
    x = Sheets("DBase").Range("A2:F" & lRow)

    ReDim y(1 To iCount, 1 To 6)

    For r = 1 To UBound(x, 1)
        For c = 1 To UBound(x, 2)
            If x(r, 5) = "B" Then
                y(r, c) = x(rCel, c) '/ Trying to make the data that fits the criteria fit into a smaller array.
            End If
            rCel = rCel + 1
        Next c
    Next r
'/ Transfer to spreadsheet.
    Sheets("CO-A").Range("A1:F" & iCount) = y
End Sub

I've attached a workbook.
Help me to understand what I'm doing wrong.
Thanks,
Xrull