Sub articule()
Dim exists_dict As Object, not_exists_dict As Object, key As Variant
Dim arr As Variant, j As Long, i As Long, lr As Long
' создаем словари
Set exists_dict = CreateObject("Scripting.Dictionary")
Set not_exists_dict = CreateObject("Scripting.Dictionary")

' записываем значения с листа Исходник в массив и загружаем в словарь
With Worksheets("Исходник")
    arr = .Cells(2, 1).CurrentRegion
    For i = 2 To UBound(arr, 1) ' 2 - потому, что игнорируем первую строку с заголовком
        For j = 2 To UBound(arr, 2)
            ' если значение ячейки d j столбце не пусто то:
            If arr(i, j) <> "" Then not_exists_dict(arr(i, 1) & ":" & arr(i, j)) = ""
        Next j
    Next i
End With

With Worksheets("Результат")
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце
    arr = .Range("A2:B" & lr) ' загружаем значения в массив
    ' загружаем значения из массива в словарь
    For i = LBound(arr, 1) To UBound(arr, 1)
        exists_dict(arr(i, 1) & ":" & arr(i, 2)) = ""
    Next i
    'проверяем есть ли совпадения ключей из словаря not_exists_dict в exists_dict на листе Результат
    For Each key In not_exists_dict.keys()
        If Not exists_dict.exists(key) Then '  если совпадений нет, то:
            arr = Split(key, ":") ' создаем массив, разбивая значение ключа по :
            lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце
            .Cells(lr + 1, 1).Resize(1, UBound(arr) + 1) = arr ' записываем в первую непустую строку значение массива arr
        End If
    Next key
End With
End Sub

Sub articule()
Dim exists_dict As Object, not_exists_dict As Object, key As Variant
Dim arr As Variant, j As Long, i As Long, lr As Long, flag As Boolean, str As String

' создаем словари
Set exists_dict = CreateObject("Scripting.Dictionary")
Set not_exists_dict = CreateObject("Scripting.Dictionary")

' записываем значения с листа Исходник в массив и загружаем в словарь
With Worksheets("Исходник")
    arr = .Cells(2, 1).CurrentRegion
    For i = 2 To UBound(arr, 1) ' 2 - потому, что игнорируем первую строку с заголовком
        For j = 2 To UBound(arr, 2)
            ' если значение ячейки d j столбце не пусто то:
            If arr(i, j) <> "" Then not_exists_dict("'" & arr(i, 1) & ":" & arr(i, j)) = ""
        Next j
    Next i
End With

With Worksheets("Результат")
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце
    arr = .Range("A2:B" & lr) ' загружаем значения в массив
    ' загружаем значения из массива в словарь
    For i = LBound(arr, 1) To UBound(arr, 1)
         If arr(i, 1) <> arr(i, 2) Then exists_dict("'" & arr(i, 1) & ":" & arr(i, 2)) = ""
    Next i
    
    flag = True
    str = Split(not_exists_dict.keys()(1), ":")(0)
    
    'проверяем есть ли совпадения ключей из словаря not_exists_dict в exists_dict на листе Результат
    For Each key In not_exists_dict.keys()
        If Not exists_dict.exists(key) Then '  если совпадений нет, то:
            arr = Split(key, ":")
            lr = .Cells(.Rows.Count, 1).End(xlUp).Row ' определяем последнюю заполненную строку на листе в 1 столбце
            If str <> arr(0) Then flag = True
            If flag Then
                .Cells(lr + 1, 1).Resize(1, 2) = arr(0)
                str = arr(0): flag = False: lr = lr + 1
            End If
            .Cells(lr + 1, 1).Resize(1, UBound(arr) + 1) = arr ' записываем в первую непустую строку значение массива arr
        End If
    Next key
End With
End Sub