Из диапазона список значений, расположенных правее ячеек с искомым словом

Утро доброе! Имеется таблица Excel
Красным я отметил ячейку перед важной информацией Справа от красного нужная мне инфа Инфа хаотично разбросана
В ячейке после красной, лежит нужная инфа (на одной строке). Её нужно перенести в пустой столбец. Как вырвать соседнюю ячейку?
Пример

Ответ

В указанном диапазоне ищем слово. Из значений правее ячеек со словом формируем массив. После обработки массив выгружаем на лист
Sub ValueOnTheRight() Dim aRes() Dim rRng As Range, c Dim lCnt As Long, k As Long Const sStr As String = "Industry" Set rRng = Range("C2:K250") lCnt = Application.CountIf(rRng, sStr) ReDim aRes(1 To lCnt, 1 To 1)
For Each c In rRng If c.Value = sStr Then k = k + 1 aRes(k, 1) = c.Offset(, 1).Value End If Next c
Range("L2:L" & k + 1).Value = aRes End Sub
Макрос разместить в общем модуле.
Эту же задачу выполняет формула
=ЕСЛИОШИБКА(ИНДЕКС($A$1:$L$250; НАИМЕНЬШИЙ( ЕСЛИ($C$2:$K$250="Industry";СТРОКА($C$2:$K$250)+СТОЛБЕЦ($C$2:$K$250)*0,001);СТРОКА(A1)); 1+ПРАВБ(НАИМЕНЬШИЙ( ЕСЛИ($C$2:$K$250="Industry";СТРОКА($C$2:$K$250)+СТОЛБЕЦ($C$2:$K$250)*0,001);СТРОКА(A1)); 3));"")
Формула массива. Записать в ячейку, в режиме редактирования нажать Ctrl+Shift+Enter - формула должна заключиться в фигурные скобки. Копировать (протянуть) ячейку вниз.
Недостатки формулы:
требует специального ввода; производит много вычислений, при большом количестве может вызвать подтормаживание при пересчетах; по строкам протягивать нужно с запасом, иначе можно не увидеть последних значений.
' ---------------------
Дополнение. Вывод результата построчно в сответствии с найденными значениями.
Sub ValueOnTheRight2() Dim aRes() Dim rRng As Range, c Dim lCnt As Long Const sStr As String = "Industry" Set rRng = Range("C1:K250"): lCnt = rRng.Rows.Count ReDim aRes(1 To lCnt, 1 To 1)
For Each c In rRng If c.Value = sStr Then aRes(c.Row, 1) = c.Offset(, 1).Value End If Next c
Range("L1:L250").Value = aRes End Sub
Если в одной строке несколько искомых значений, в результат запишется только одно. Для накопления изменить строку записи:
aRes(c.Row, 1) = aRes(c.Row, 1) & " " & c.Offset(, 1).Value