Option Compare Text
Sub tt()
    tt_ = Timer
    r0_ = 2
    c1_ = Cells(r0_, Columns.Count).End(1).Column
    c0_ = 1
    n1_ = Cells(Rows.Count, c1_).End(3).Row - r0_ + 1
    n0_ = Cells(Rows.Count, c0_).End(3).Row - r0_ + 1
    ar1 = Cells(r0_, c1_).Resize(n1_)
    ar0 = Cells(r0_, c0_).Resize(n0_, c1_ - 2)
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    Set slov = CreateObject("Scripting.Dictionary")
    Set slov1 = CreateObject("Scripting.Dictionary")
    slov1.CompareMode = 1
    Set sh = Worksheets("zero")
    sh.Cells.Clear
    With slov
        For i = 1 To n1_
            If Not slov1.Exists(ar1(i, 1)) Then
                qqq = slov1.Item(ar1(i, 1))
                z_ = z_ + 1
                zz_ = 0
                For j = 1 To n0_
                    If ar1(i, 1) = ar0(j, 1) Or ar1(i, 1) = ar0(j, 2) Then
                        zz_ = zz_ + 1
                        .Item(zz_) = WorksheetFunction.Index(ar0, j, 0)
                    End If
                Next j
                If .Count Then
                    sh.Cells(1, 1 + (z_ - 1) * (c1_ - 1)).Resize(zz_, 15) = Application.Transpose(Application.Transpose(.Items))
                    .RemoveAll
                End If
            End If
        Next i
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
    MsgBox Timer - tt_
End Sub

sh.Cells(1, 1 + (z_ - 1) * (c1_ - 1)).Resize(zz_, 15) = Application.Transpose(Application.Transpose(.Items))

sh.Cells(1, 1 + (z_ - 1) * (c1_ - 1)).Resize(zz_, 26) = Application.Transpose(Application.Transpose(.Items))

MyArr = Cells(2, 17).Resize(71).Value