Sub unikalnie()
    Dim newItem, colArr, s1 As Long
    'Dim Applwd As Word.Application, oWdoc As Word.Document
    'Applwd.Visible = False
    ReDim colArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each newItem In Range("A2", Cells(Rows.Count, 1).End(xlUp)).Value
            .Add newItem, CStr(newItem)
            If Err = 0 Then
                s1 = s1 + 1: colArr(s1, 1) = newItem
            Else: Err.Clear
            End If
        Next
    End With
    If s1 Then [C2].Resize(s1).Value = colArr
    Dim v, s$
    With CreateObject("shell.application").Namespace(0)
        For Each v In Range("D2", Cells(Rows.Count, 4).End(xlUp)).Value
            If Dir$(v) <> "" Then
                .parsename(v).InvokeVerbEx "Print"
            Else
                Debug.Print v
                s = s & vbLf & v
            End If
        Next
    End With
    If s <> "" Then MsgBox "Следующие файлы не были найдены:" & s
    'oWdoc.PrintOut Copies:=1
    'oWdoc.Close
    'Applwd.Quit
    'Set Applwd = Nothing
End Sub