Необходимо создать макрос для решения следующего условия: Имеются два столбца с данными. Необходимо в столбце B для каждой заполненной ячейке найти искомое значение, например <АБВ> (искомое значение для всех одинаковое) и заменить это вхождение на значение ячейки столбца A той же строки. Например A1=ГДЕ B1= текст<АБВ>текст после выполнения макроса значение ячейки B1=текстГДЕтекст
Здравствуйте!
Необходимо создать макрос для решения следующего условия: Имеются два столбца с данными. Необходимо в столбце B для каждой заполненной ячейке найти искомое значение, например <АБВ> (искомое значение для всех одинаковое) и заменить это вхождение на значение ячейки столбца A той же строки. Например A1=ГДЕ B1= текст<АБВ>текст после выполнения макроса значение ячейки B1=текстГДЕтекстgugyk
Sub replaceValue(Ftext As String) Dim wb, sh, lr, f, nt, str, n wb = ThisWorkbook.Name sh = ActiveSheet.Name lr = Workbooks(wb).Sheets(sh).Cells(Rows.Count, 2).End(xlUp).Row nt = Len(Ftext) For f = 1 To lr str = Workbooks(wb).Sheets(sh).Cells(f, 2).Value kn = Len(str) For n = 1 To kn Step nt If Mid(str, n, nt) = Ftext Then str = Left(str, n) & Workbooks(wb).Sheets(sh).Cells(f, 1) & Mid(str, n + nt, kn - n - nt) End If Next n Workbooks(wb).Sheets(sh).Cells(f, 2).Value = str Next f End Sub
[/vba]
например так: [vba]
Код
Sub replaceValue(Ftext As String) Dim wb, sh, lr, f, nt, str, n wb = ThisWorkbook.Name sh = ActiveSheet.Name lr = Workbooks(wb).Sheets(sh).Cells(Rows.Count, 2).End(xlUp).Row nt = Len(Ftext) For f = 1 To lr str = Workbooks(wb).Sheets(sh).Cells(f, 2).Value kn = Len(str) For n = 1 To kn Step nt If Mid(str, n, nt) = Ftext Then str = Left(str, n) & Workbooks(wb).Sheets(sh).Cells(f, 1) & Mid(str, n + nt, kn - n - nt) End If Next n Workbooks(wb).Sheets(sh).Cells(f, 2).Value = str Next f End Sub
Sub replaceValue(Ftext As String) Dim wb, sh, lr, f, nt, str, n wb = ThisWorkbook.Name sh = ActiveSheet.Name lr = Workbooks(wb).Sheets(sh).Cells(Rows.Count, 2).End(xlUp).Row nt = Len(Ftext) For f = 1 To lr str = Workbooks(wb).Sheets(sh).Cells(f, 2).Value kn = Len(str) For n = 1 To kn Step nt If Mid(str, n, nt) = Ftext Then str = Left(str, n) & Workbooks(wb).Sheets(sh).Cells(f, 1) & Mid(str, n + nt, kn - n - nt) End If Next n Workbooks(wb).Sheets(sh).Cells(f, 2).Value = str Next f End Sub
Спасибо, немного подправил убрал шаг в цикле, все корректно заработало
Sub replaceValue(Ftext As String) Dim wb, sh, lr, f, nt, str, n wb = ThisWorkbook.Name sh = ActiveSheet.Name lr = Workbooks(wb).Sheets(sh).Cells(Rows.Count, 2).End(xlUp).Row nt = Len(Ftext) For f = 1 To lr str = Workbooks(wb).Sheets(sh).Cells(f, 2).Value kn = Len(str) For n = 1 To kn Step nt If Mid(str, n, nt) = Ftext Then str = Left(str, n) & Workbooks(wb).Sheets(sh).Cells(f, 1) & Mid(str, n + nt, kn - n - nt) End If Next n Workbooks(wb).Sheets(sh).Cells(f, 2).Value = str Next f End Sub
Спасибо, немного подправил убрал шаг в цикле, все корректно заработалоgugyk
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
