Sub ertert()
Dim x, y, i&, j&
With Sheets("Sheet1")
     x = .Range("A1:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With: x(1, 4) = "Факт"
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 1 To UBound(x)
         .Item(x(i, 1) & "~" & x(i, 2)) = i
     Next i
     With Sheets("Sheet2")
         y = .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
     End With
     For i = 1 To UBound(y)
         If .Exists(y(i, 1) & "~" & y(i, 2)) Then
             x(.Item(y(i, 1) & "~" & y(i, 2)), 4) = y(i, 3)
         Else
             j = j + 1
             y(j, 1) = y(i, 1): y(j, 2) = y(i, 2)
             y(j, 3) = "": y(j, 4) = y(i, 3)
         End If
     Next i
End With
With Sheets("Sheet3").Range("A1")
     .CurrentRegion.ClearContents
     .Resize(UBound(x), 4).Value = x
     .Item(UBound(x) + 1, 1).Resize(j, 4).Value = y
     With .CurrentRegion
         .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
     End With
End With
End Sub