Dim iYvvod As Long
    Dim iYcorr As Long
    Dim shVvod As Worksheet
    Dim shCorr As Worksheet
    Dim shResu As Worksheet
    Dim arrResu() As Variant
    
    Set shVvod = Sheets("вводные данные")
    Set shCorr = Sheets("таблица соответствия")
    Set shResu = Sheets("результат")
        
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
     
    With shVvod.Columns(1)
        ReDim arrResu(.Cells(Rows.Count).End(xlUp).Row - 1, 1)
        
        For iYvvod = 1 To .Cells(Rows.Count).End(xlUp).Row
            arrResu(iYvvod - 1, 0) = .Cells(iYvvod).Value
            
            For iYcorr = 1 To shCorr.Cells(Rows.Count, 1).End(xlUp).Row
                If InStr(arrResu(iYvvod - 1, 0), shCorr.Cells(iYcorr, 1).Text) > 0 Then
                     arrResu(iYvvod - 1, 1) = arrResu(iYvvod - 1, 1) & IIf(arrResu(iYvvod - 1, 1) = "", "", ", ") & shCorr.Cells(iYcorr, 2).Text
                End If
            Next iYcorr
            
        Next iYvvod
    End With
     
    With shResu
        .Cells.Clear
        .Range(.Cells(1, 1), .Cells(UBound(arrResu, 1) + 1, 2)) = arrResu()
    End With

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With