Добрый день! Помогите решить задачу по поиску слов с копированием на новый лист в отдельную колонку. См. файл. Условие: Нужно найти все фамилии с должностью БП и скопировать на новый лист в колонку. Т.е создав условие поиска ...БП(пробел)... ПОИСК....и после этого результат поиска всех БП + связанная с запросом фамилия будет на новом листе в отдельной колонке.
Добрый день! Помогите решить задачу по поиску слов с копированием на новый лист в отдельную колонку. См. файл. Условие: Нужно найти все фамилии с должностью БП и скопировать на новый лист в колонку. Т.е создав условие поиска ...БП(пробел)... ПОИСК....и после этого результат поиска всех БП + связанная с запросом фамилия будет на новом листе в отдельной колонке.stria
Sub bp() Dim result() arr = Sheets(1).Range("a1:a14").Value For i = 1 To UBound(arr) If Not IsEmpty(arr(i, 1)) Then txt = txt & " " & arr(i, 1) Next With CreateObject("VBScript.RegExp") .Pattern = "(?:БП )([^.]+[.А-Я]{2}\.)" .Global = True ReDim result(0 To .Execute(txt).Count - 1) For i = 0 To .Execute(txt).Count - 1 result(i) = .Execute(txt)(i).submatches(0) Next End With Sheets(2).Cells(1).Resize(i, 1).Value = Application.Transpose(result) End Sub
[/vba]
Сделал как понял [vba]
Код
Sub bp() Dim result() arr = Sheets(1).Range("a1:a14").Value For i = 1 To UBound(arr) If Not IsEmpty(arr(i, 1)) Then txt = txt & " " & arr(i, 1) Next With CreateObject("VBScript.RegExp") .Pattern = "(?:БП )([^.]+[.А-Я]{2}\.)" .Global = True ReDim result(0 To .Execute(txt).Count - 1) For i = 0 To .Execute(txt).Count - 1 result(i) = .Execute(txt)(i).submatches(0) Next End With Sheets(2).Cells(1).Resize(i, 1).Value = Application.Transpose(result) End Sub
_Boroda_, Попробовал некоторые изменения сделать в условия поиска и формула перестала работать. Теперь для поиска не БП, а КВС. Может что то не так? Посмотрите в новом файле
_Boroda_, Попробовал некоторые изменения сделать в условия поиска и формула перестала работать. Теперь для поиска не БП, а КВС. Может что то не так? Посмотрите в новом файлеstria
sboy, Спасибо. Меняю фамилии и макрос не работает при новых данных. Что в макросе нужно переписать, чтобы изменить условия поиска? Например не БП искать, а КВС?
sboy, Спасибо. Меняю фамилии и макрос не работает при новых данных. Что в макросе нужно переписать, чтобы изменить условия поиска? Например не БП искать, а КВС?stria
Конечно, вот смотрите: 1. В "БП " 3 буквы, а в "КВС " 4, следовательно, в ПСТР нужно все 3 заменить на 4. 2. Это формула массива (видите в моем файле фигурные скобочки по краям формулы? - они указывают на это), она вводится одновременным нажатием Контрл Шифт Ентер 3. В предыдущей формуле было до 99 строки в столбце А, а у Вас сейчас там 177 строк заполнено
Конечно, вот смотрите: 1. В "БП " 3 буквы, а в "КВС " 4, следовательно, в ПСТР нужно все 3 заменить на 4. 2. Это формула массива (видите в моем файле фигурные скобочки по краям формулы? - они указывают на это), она вводится одновременным нажатием Контрл Шифт Ентер 3. В предыдущей формуле было до 99 строки в столбце А, а у Вас сейчас там 177 строк заполнено
в ячейку B1 пишите, что нужно искать, потом запускайте [vba]
Код
Sub bp() Dim result() With Sheets(1) arr = Range(.Cells(1), .Cells(.Rows.Count, 1).End(xlUp)).Value p = .Cells(2).Value End With For i = 1 To UBound(arr) If Not IsEmpty(arr(i, 1)) Then txt = txt & " " & arr(i, 1) Next With CreateObject("VBScript.RegExp") .Pattern = "(?:" & p & " )([^.]+[.А-Я]{2}\.)" .Global = True ReDim result(0 To .Execute(txt).Count - 1) For i = 0 To .Execute(txt).Count - 1 result(i) = .Execute(txt)(i).submatches(0) Next End With Sheets(2).Cells(1).Resize(i, 1).Value = Application.Transpose(result) End Sub
в ячейку B1 пишите, что нужно искать, потом запускайте [vba]
Код
Sub bp() Dim result() With Sheets(1) arr = Range(.Cells(1), .Cells(.Rows.Count, 1).End(xlUp)).Value p = .Cells(2).Value End With For i = 1 To UBound(arr) If Not IsEmpty(arr(i, 1)) Then txt = txt & " " & arr(i, 1) Next With CreateObject("VBScript.RegExp") .Pattern = "(?:" & p & " )([^.]+[.А-Я]{2}\.)" .Global = True ReDim result(0 To .Execute(txt).Count - 1) For i = 0 To .Execute(txt).Count - 1 result(i) = .Execute(txt)(i).submatches(0) Next End With Sheets(2).Cells(1).Resize(i, 1).Value = Application.Transpose(result) End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
