Public Sub www()
    Dim sh As Worksheet, i&
    For Each sh In ThisWorkbook.Worksheets
        For i = 2 To sh.UsedRange.Rows.Count
            If Not sh Is Me Then
                If sh.Cells(i, 2).Interior.ColorIndex = 43 Then
                    If Application.CountIf(Me.[a2].CurrentRegion, sh.Cells(i, 2).Value) = 0 Then _
                       sh.Cells(i, 2).Copy Me.Cells(Me.Rows.Count, 1).End(xlUp)(2, 1)
                End If
            End If
        Next
    Next
End Sub

Public Sub www()
    Dim sh As Worksheet, i&, a, d1 As Object
    Set d1 = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If Not sh Is Me Then
            For i = 2 To sh.UsedRange.Rows.Count
                If sh.Cells(i, 2).Interior.ColorIndex = 43 Then
                    d1(sh.Cells(i, 2).Value) = ""
                End If
            Next
        End If
    Next
    a = d1.keys
    ReDim b(1 To UBound(a) + 1, 1 To 1)
    For i = 0 To UBound(a): b(i + 1, 1) = a(i): Next
    Me.[a1].Resize(i) = b
End Sub

Sub MacroCollector()
Dim LastRow As Long, i As Long, n As Long, Arr, Uniq As New Collection, x As Long, Material
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 1)).Clear
    For n = 1 To Sheets.Count
        With Sheets(n)
            If .Name <> ActiveSheet.Name Then
                LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = 2 To LastRow
                    On Error Resume Next
                    If .Cells(i, 1).Interior.Color <> 16777215 Then Uniq.Add .Cells(i, 2), CStr(.Cells(i, 2))
                Next
            End If
        End With
    Next
    ReDim Arr(1 To Uniq.Count, 1 To 1)
    For Each Material In Uniq
        x = x + 1
        Arr(x, 1) = Material
    Next
    Range("A2").Resize(x, 1).Value = Arr
    Application.ScreenUpdating = True
End Sub