Sub Макрос1()
    Dim n As Long, sd As Object
    Set sd = CreateObject("Scripting.Dictionary")
    With Workbooks("два списка_остатки.xlsx").Worksheets("Лист1")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr_1 = .Range("A2:A" & n).Value
        For n = 1 To UBound(arr_1)
            If arr_1(n, 1) <> "" Then
                If Not sd.Exists(arr_1(n, 1)) Then
                    sd.Add arr_1(n, 1), 1
                Else
                    sd(arr_1(n, 1)) = sd(arr_1(n, 1)) + 1
                End If
            End If
        Next
    End With
    With ThisWorkbook.Worksheets("Лист1")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr_2 = .Range("A1:A" & n).Value
        For n = 1 To UBound(arr_2)
            If arr_2(n, 1) <> "" Then
                If sd.Exists(arr_2(n, 1)) Then
                    If sd(arr_2(n, 1)) > 0 Then
                        sd(arr_2(n, 1)) = sd(arr_2(n, 1)) - 1
                        .Cells(n, 1).Interior.Color = 65535
                    End If
                End If
            End If
        Next
    End With
End Sub