Доброго дня форумчанам! Нужна помощь с написание макроса, сам не пойму как реализовать функцию.
Ситуация следующая: Есть макрос, который перебирает строки и проверяет синтаксис доменных имен. Есть база типовых ошибок, которую он сравнивает с каждым перебираемым адресом. Сейчас каждую строку с найденными ошибками он заливает цветом, и приходится ошибки потом править руками. Есть ли возможность реализовать автозамену ошибочной части на правильную? Пример желаемого: находим запись www.excelworld.ry - автоматом меняем окончание на .ru, не меняя начала (www.excelworld).
[vba]
Код
Sub color_() a = Array("*.kom", "*.ry", "*.r", "*.u") c = ActiveCell.Column For r = Cells(Rows.Count, c).End(xlUp).Row To 2 Step -1
For Each Word In a If Cells(r, c) Like Word Then Rows(r).Interior.ColorIndex = 6 End If Next Word
Next r End Sub
[/vba]
Доброго дня форумчанам! Нужна помощь с написание макроса, сам не пойму как реализовать функцию.
Ситуация следующая: Есть макрос, который перебирает строки и проверяет синтаксис доменных имен. Есть база типовых ошибок, которую он сравнивает с каждым перебираемым адресом. Сейчас каждую строку с найденными ошибками он заливает цветом, и приходится ошибки потом править руками. Есть ли возможность реализовать автозамену ошибочной части на правильную? Пример желаемого: находим запись www.excelworld.ry - автоматом меняем окончание на .ru, не меняя начала (www.excelworld).
[vba]
Код
Sub color_() a = Array("*.kom", "*.ry", "*.r", "*.u") c = ActiveCell.Column For r = Cells(Rows.Count, c).End(xlUp).Row To 2 Step -1
For Each Word In a If Cells(r, c) Like Word Then Rows(r).Interior.ColorIndex = 6 End If Next Word
Sub color_() ar0 = Array("*.kom", "*.ry", "*.r", "*.u") ar1 = Array("*.com", "*.ru", "*.ru", "*.ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) If ar(i, 1) Like ar0(j) Then ar(i, 1) = Replace(ar(i, 1), ar0(j), ar1(j)) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
[/vba] Поскольку файла нет, то макрос проверять негде было. Ежели чего - самостоятельно там поправьте
Так нужно? [vba]
Код
Sub color_() ar0 = Array("*.kom", "*.ry", "*.r", "*.u") ar1 = Array("*.com", "*.ru", "*.ru", "*.ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) If ar(i, 1) Like ar0(j) Then ar(i, 1) = Replace(ar(i, 1), ar0(j), ar1(j)) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
[/vba] Поскольку файла нет, то макрос проверять негде было. Ежели чего - самостоятельно там поправьте_Boroda_
_Boroda_, а разве в реплейсе звездочки применяются? мой вариант [vba]
Код
Sub color_() a = Array("*.kom", "*.ry", "*.r", "*.u") b = Array("com", "ru") c = ActiveCell.Column For r = Cells(Rows.Count, c).End(xlUp).Row To 2 Step -1 t = Cells(r, c).Value For i = 0 To UBound(a) If t Like a(i) Then Select Case i Case 0: y = 3: x = 0 Case 1: y = 2: x = 1 Case Else: y = 1: x = 1 End Select Cells(r, c).Value = Left(t, Len(t) - y) & b(x) Exit For End If Next i Next r End Sub
[/vba]
_Boroda_, а разве в реплейсе звездочки применяются? мой вариант [vba]
Код
Sub color_() a = Array("*.kom", "*.ry", "*.r", "*.u") b = Array("com", "ru") c = ActiveCell.Column For r = Cells(Rows.Count, c).End(xlUp).Row To 2 Step -1 t = Cells(r, c).Value For i = 0 To UBound(a) If t Like a(i) Then Select Case i Case 0: y = 3: x = 0 Case 1: y = 2: x = 1 Case Else: y = 1: x = 1 End Select Cells(r, c).Value = Left(t, Len(t) - y) & b(x) Exit For End If Next i Next r End Sub
Поскольку файла нет, то макрос проверять негде было
Вот так тогда [vba]
Код
Sub color_() ar0 = Array(".kom", ".ry", ".r", ".u") ar1 = Array(".com", ".ru", ".ru", ".ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) If InStr(ar(i, 1), ar0(j)) Then ar(i, 1) = Replace(ar(i, 1), ar0(j), ar1(j)) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
Поскольку файла нет, то макрос проверять негде было
Вот так тогда [vba]
Код
Sub color_() ar0 = Array(".kom", ".ry", ".r", ".u") ar1 = Array(".com", ".ru", ".ru", ".ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) If InStr(ar(i, 1), ar0(j)) Then ar(i, 1) = Replace(ar(i, 1), ar0(j), ar1(j)) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
Согласен. Raskat, вот к чему приводит отсутствие файла-примера! Сколько времени зря потрачено!
[vba]
Код
Sub color_() ar0 = Array(".kom", ".ry", ".r", ".u") ar1 = Array(".com", ".ru", ".ru", ".ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) dl_ = Len(ar0(j)) If Right(ar(i, 1), dl_) = ar0(j) Then ar(i, 1) = Left(ar(i, 1), Len(ar(i, 1)) - dl_) & ar1(j) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
[/vba]
[vba]
Код
Sub color1_() ar0 = Array("*.kom", "*.ry", "*.r", "*.u") ar1 = Array(".com", ".ru", ".ru", ".ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) If ar(i, 1) Like ar0(j) Then ar(i, 1) = Left(ar(i, 1), Len(ar(i, 1)) - Len(ar0(j) + 1) & ar1(j)) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
[/vba]
* Всё, надоело
Согласен. Raskat, вот к чему приводит отсутствие файла-примера! Сколько времени зря потрачено!
[vba]
Код
Sub color_() ar0 = Array(".kom", ".ry", ".r", ".u") ar1 = Array(".com", ".ru", ".ru", ".ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) dl_ = Len(ar0(j)) If Right(ar(i, 1), dl_) = ar0(j) Then ar(i, 1) = Left(ar(i, 1), Len(ar(i, 1)) - dl_) & ar1(j) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
[/vba]
[vba]
Код
Sub color1_() ar0 = Array("*.kom", "*.ry", "*.r", "*.u") ar1 = Array(".com", ".ru", ".ru", ".ru") c_ = ActiveCell.Column r1_ = Cells(Rows.Count, c_).End(xlUp).Row - 1 ar = Cells(2, c_).Resize(r1_) For i = 1 To r1_ For j = 0 To UBound(ar0) If ar(i, 1) Like ar0(j) Then ar(i, 1) = Left(ar(i, 1), Len(ar(i, 1)) - Len(ar0(j) + 1) & ar1(j)) End If Next j Next i Cells(2, c_).Resize(r1_) = ar End Sub
1. Чтобы случайно не назвать переменную зарезервированным в VBA именем. Обычно (не всегда) это не особо страшно, но лучше не стОит 2. Одна из самых тормознутых вещей в VBA - это работа с ячейками (диапазонами) на листе. Есл иячеек не очень много, то это не сильно заметно, но чем их больше, тем все печальнее Поэтому я обращаюсь к листу всего два раза (не считая определения последней заполненной строки) - 1) взял диапазон в массив ar, поработал я этим массивом и 2) положил массив обратно
1. Чтобы случайно не назвать переменную зарезервированным в VBA именем. Обычно (не всегда) это не особо страшно, но лучше не стОит 2. Одна из самых тормознутых вещей в VBA - это работа с ячейками (диапазонами) на листе. Есл иячеек не очень много, то это не сильно заметно, но чем их больше, тем все печальнее Поэтому я обращаюсь к листу всего два раза (не считая определения последней заполненной строки) - 1) взял диапазон в массив ar, поработал я этим массивом и 2) положил массив обратно_Boroda_
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
