Поиск уникальных значений в динамическом массиве с переносом их другой лист

Sub Копировать_уникальные()
    Dim i&, j&, LastRow&, Dic As Object, A, B, S
    With Worksheets("Плейлист")
        LastRow = .UsedRange.Rows.Count
        A = .Range("A6:DS" & LastRow).Value
    End With
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    With Worksheets("Уникальные значение") ' или With Worksheets("иникальные значение") '- в файле примера
        .UsedRange.Offset(1, 0).ClearContents
        For i = 1 To UBound(A)
            For j = 1 To UBound(A, 2)
                S = Trim(A(i, j))
                If S <> "" Then
                    If Not Dic.Exists(S) Then
                        Dic(S) = 0&
                        B(i, j) = S
                    End If
                End If
            Next j
        Next i
        .Range("A2").Resize(UBound(B), UBound(B, 2)) = B
    End With
End Sub

Sub Копировать_уникальные()
    Dim i&, j&, LastRow&, Dic As Object, A, B, S
    With Worksheets("Плейлист")
        LastRow = .UsedRange.Rows.Count
        A = .Range("A6:DS" & LastRow).Value
    End With
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    With Worksheets("Уникальные значение") ' или With Worksheets("иникальные значение") '- в файле примера
        .UsedRange.Offset(1, 0).ClearContents
        For j = 1 To UBound(A, 2)
            For i = 1 To UBound(A)
                S = Trim(A(i, j))
                If S <> "" Then
                    If Not Dic.Exists(S) Then
                        Dic(S) = 0&
                        B(i, j) = S
                    End If
                End If
            Next i
        Next j
        .Range("A2").Resize(UBound(B), UBound(B, 2)) = B
    End With
End Sub

Sub Копировать_уникальные()
    Dim i&, j&, k&, LastRow&, Dic As Object, A, B, S
    With Worksheets("Плейлист")
        LastRow = .UsedRange.Rows.Count
        A = .Range("A6:DS" & LastRow).Value
    End With
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    With Worksheets("Уникальные значение") ' или With Worksheets("иникальные значение") '- в файле примера
        .UsedRange.Offset(1, 0).ClearContents
        For j = 1 To UBound(A, 2)
            k = 0
            For i = 1 To UBound(A)
                S = Trim(A(i, j))
                If S <> "" Then
                    If Not Dic.Exists(S) Then
                        Dic(S) = 0&
                        k = k + 1
                        B(k, j) = S
                    End If
                End If
            Next i
        Next j
        .Range("A2").Resize(UBound(B), UBound(B, 2)) = B
    End With
End Sub

Sub Копировать_уникальные()
    Dim i&, j&, k&, LastRow&, Dic As Object, A, B, S
    With Worksheets("Плейлист")
        LastRow = .UsedRange.Rows.Count
        A = .Range("A6:DS" & LastRow).Value
    End With
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    With Worksheets("Лист1")
        .UsedRange.Offset(3, 0).ClearContents
        For j = 1 To UBound(A, 2)
            k = 0
            For i = 1 To UBound(A)
                S = Trim(A(i, j))
                If S <> "" Then
                    If Not Dic.Exists(S) Then
                        Dic(S) = 0&
                        k = k + 1
                        B(k, j) = S
                    End If
                End If
            Next i
        Next j
        .Range("A4").Resize(UBound(B), UBound(B, 2)) = B
    End With
End Sub

Sub Копировать_уникальные()
    Dim i&, j&, k&, LastRow&, LastCol&, Dic As Object, A, B, C, S
    With Worksheets("Плейлист")
        LastRow = .UsedRange.Rows.Count
        A = .Range("A6:DS" & LastRow).Value
    End With
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    ReDim C(1 To UBound(A), 1 To 1)
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    With Worksheets("Уникальные значение")
        .UsedRange.Offset(3, 0).ClearContents
        For j = 1 To UBound(A, 2)
            k = 0
            For i = 1 To UBound(A)
                S = Trim(A(i, j))
                If S <> "" Then
                    If Not Dic.Exists(S) Then
                        Dic(S) = 0&
                        k = k + 1
                        B(k, j) = S
                        LastCol = j
                    End If
                End If
            Next i
        Next j
        .Range("A4").Resize(UBound(B), UBound(B, 2)) = B
    End With
    For i = 1 To UBound(B)
        C(i, 1) = B(i, LastCol)
    Next i
    With Worksheets("Лист1")
        .UsedRange.Offset(3, 0).ClearContents
        .Range("A4").Resize(UBound(C), UBound(C, 2)) = C
    End With
End Sub