arcnik, этой задаче (судя по дате в заголовке) уже больше года. Думается, что автор уже получил желаемое решение.
Кстати, если мне не изменяет память, варианты решений были опубликованы и здесь, только, похоже, после серии чисток потерялись.
На тот случай, если они кому-то всё-таки нужны, опубликую их заново.
1. Вариант с макросом.
Option Compare Text
Sub Example()
Dim objRange As Range, objTemplates As Name, objCell As Range
Dim intShList As Integer, intBaseBar As Integer, strTemplates As String
Dim strTemp As String, arrTemp
intShList = 1 'Порядковый номер листа (в книге) с обрабатываемым списком.
intBaseBar = 1 'Порядковый номер столбца (на листе) с обрабатываемым списком.
strTemplates = "Шаблоны" 'Имя диапазона ячеек с шаблонами наименований изделий
'(должен быть расположен в одном столбце или одной строке).
On Error Resume Next
Set objTemplates = ThisWorkbook.Names(strTemplates)
If Err.Number = 0 Then
If UBound(objTemplates.RefersToRange.Value, 2) > 1 Then
If UBound(objTemplates.RefersToRange.Value, 1) = 1 Then
arrTemp = Application.Transpose(Application.Transpose(objTemplates.RefersToRange))
Else
MsgBox "Список шаблонов должен быть задан столбцом или строкой.", vbCritical
End If
Else
arrTemp = Application.Transpose(objTemplates.RefersToRange)
End If
If IsArray(arrTemp) Then
With Worksheets(intShList)
'--- Предварительное удаление текстовых значений из ячеек,
'расположенных в столбцах правее столбца с обрабатываемым списком
'(не обязательное действие).
Set objRange = .Range(Columns(intBaseBar + 1), Columns(256)).Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
If Err.Number = 0 Then
objRange.ClearContents
Else
Err.Clear
End If
'------
Set objRange = .Columns(intBaseBar).Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
If Err.Number = 0 Then
For Each objCell In objRange
strTemp = objCell.Value
For i = LBound(arrTemp) To UBound(arrTemp)
If InStr(strTemp, arrTemp(i)) > 0 Then
.Cells(objCell.Row, intBaseBar + i).Value = strTemp
Exit For
End If
Next
Next
Else
MsgBox "В заданном диапазоне подходящих ячеек не найдено.", vbCritical
Err.Clear
End If
Erase arrTemp
Set objRange = Nothing
'--- Автонастройка ширины колонок, содержащих какие-либо данные
'(не обязательное действие).
.UsedRange.Columns.AutoFit
'------
End With
MsgBox "Готово.", vbInformation
End If
Else
MsgBox "Именованый диапазон " & UCase(strTemplates) & " не найден.", vbCritical
Err.Clear
End If
Set objTemplates = Nothing
End Sub
2. Варианты с формулами рабочих листов можно скачать здесь: http://fayloobmennik.net/492785