Sub OtsutstvNom()
    t_ = Timer
    Application.ScreenUpdating = 0
    c0_ = 13
    r0_ = 2
    n0_ = Cells(Rows.Count, c0_).End(3).Row - r0_ + 1
    ar0 = Cells(r0_, c0_).Resize(n0_, 2)
    c1_ = 17
    r1_ = 2
    n1_ = Cells(Rows.Count, c1_).End(3).Row - r1_ + 1
    ar1 = Cells(r1_, c1_).Resize(n1_, 3)
    Set slov = CreateObject("Scripting.Dictionary")
    With slov
        .comparemode = 1
        For i = 1 To n1_
            Set slov1 = CreateObject("Scripting.Dictionary")
            .Add ar1(i, 1), slov1
            With slov1
                .RemoveAll
                For j = 1 To ar1(i, 2)
                    a = .Item(j)
                Next j
            End With
        Next i
        On Error Resume Next
        For k = 1 To n0_
            .Item(ar0(k, 1)).Remove ar0(k, 2)
        Next k
        For h = 1 To n1_
            ar1(h, 3) = Join(.Item(ar1(h, 1)).keys, ", ")
        Next h
        Cells(r1_, c1_).Resize(n1_, 3) = ar1
    End With
    Application.ScreenUpdating = 1
    MsgBox Format(Timer - t_, "0.00000")
End Sub

Type Addrs
       Ks() As String
       Its() As String
End Type
Sub ...
    Dim NewMyArray As Addrs
...
    With NewMyArray
        .Ks=Dic.Keys
        .Its=Dic.Items
    End With