Sub Найтисовпадения()
    Dim lastRowA As Long
    Dim lastRowF As Long
    Dim i As Long
    Dim j As Long
    Dim result As String
    
    Dim col As New Collection
    
    lastRowA = Sheets("Лист1").Cells(Rows.Count, "C").End(xlUp).Row
    lastRowF = Sheets("Лист2").Cells(Rows.Count, "A").End(xlUp).Row

   
    For i = 1 To lastRowF
        result = ""
        For j = 1 To lastRowA
            If Sheets("Лист2").Cells(i, "A").Value = Sheets("Лист1").Cells(j, "E").Value Then
                If result = "" Then
                    result = Sheets("Лист1").Cells(j, "C").Value
                Else
                    result = result & "; " & Sheets("Лист1").Cells(j, "C").Value
                End If
            End If
        Next j
        Sheets("Лист2").Cells(i, "C").Value = result
    Next i
     
    
    On Error Resume Next
    
    For Each cell In Selection
        Set col = Nothing
        sResult = ""
        arWords = Split(WorksheetFunction.Trim(cell.Value), "; ")
        For i = LBound(arWords) To UBound(arWords)
            Err.Clear
            col.Add arWords(i), arWords(i)
            If Err.Number = 0 Then sResult = sResult & " " & arWords(i)
        Next i
        cell.Value = Trim(sResult)
    Next cell    
End Sub

Sub ЗаполнитьПодразделения()

'Создаем объекты

Dim wb As Workbook

Dim wsSource As Worksheet

Dim wsResult As Worksheet

Dim rngSource As Range

Dim rngResult As Range

Dim lastRow As Long

Dim lastCol As Long

Dim strRaw As String

Dim arrData() As String

Dim strSeparator As String

'Инициализируем объекты

Set wb = ThisWorkbook

Set wsSource = wb.Sheets("Лист1")

Set wsResult = wb.Sheets("Лист2")

'Определяем последний ряд и последний заполненный столбец в таблице 1

lastRow = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row

lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column

'Берем данные из таблицы 1

Set rngSource = wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRow, lastCol))

arrData = rngSource.Value

'Ищем совпадения в таблице 2

Set rngResult = wsResult.Range(wsResult.Cells(2, 3), wsResult.Cells(lastRow, 3))

For i = 1 To lastRow

    strRaw = rngResult.Cells(i, 1).Value 'текущее сырье

    For j = 1 To UBound(arrData, 1)

        If arrData(j, 2) = strRaw Then 'совпадение найдено, добавляем подразделение

            rngResult.Cells(i, 3).Value = rngResult.Cells(i, 3).Value & arrData(j, 1) & "; "

        End If

    Next j

    If rngResult.Cells(i, 3).Value Like "*; " Then

        rngResult.Cells(i, 3).Value = Left(rngResult.Cells(i, 3).Value, Len(rngResult.Cells(i, 3).Value) - 2)

    ElseIf rngResult.Cells(i, 3).Value = "" Then

        rngResult.Cells(i, 3).Value = "-"

    End If

Next i

'Сообщаем о завершении

MsgBox "Заполнение подразделений завершено!", vbInformation, "Успех:)"

End Sub