Добрый день. Нужна ваша помощь. Существует таблица из 5 столбцов. в 4 столбце стоит дата рождения. Строк может быть неограниченное количество. Так как даты могут вводить вручную (кто угодно и как угодно), необходимо проверять эти даты на правильность и исправлять, где это возможно (даты должны быть приведены в формат "дд.мм.гггг"). Остальные ячейки (пустые и не верные) помечать цветом. Так же существует ограничение по возрвасту (14-90 лет). Написал скрипт. Он рабочий. Правда долго отрабатывает на большом количестве строк. Помогите, пожалуйста его усовершенствовать.
' k - количество строк For i = 2 To k Cells(i, 6).FormulaR1C1 = "=TEXT(RC[-2],""дд.ММ.гггг"")" Cells(i + 1, 6).NumberFormat = "m/d/yyyy" Cells(i + 1, 6).FormulaR1C1 = "=DATEVALUE(LEFT(R[-1]C,10))" If IsDate(Cells(i + 1, 6)) Then s = CLng(Date - CDate(Cells(i + 1, 6))) / 365 If s >= 90 Then Cells(i, 4).Interior.ColorIndex = 3 If s <= 14 Then Cells(i, 4).Interior.ColorIndex = 3 Cells(i, 6).Copy Cells(i, 4).PasteSpecial Paste:=xlPasteValues Else Cells(i, 4).Interior.ColorIndex = 6 End If Next i Range(Cells(2, 6), Cells(k + 1, 6)).Delete Shift:=xlUp
Добрый день. Нужна ваша помощь. Существует таблица из 5 столбцов. в 4 столбце стоит дата рождения. Строк может быть неограниченное количество. Так как даты могут вводить вручную (кто угодно и как угодно), необходимо проверять эти даты на правильность и исправлять, где это возможно (даты должны быть приведены в формат "дд.мм.гггг"). Остальные ячейки (пустые и не верные) помечать цветом. Так же существует ограничение по возрвасту (14-90 лет). Написал скрипт. Он рабочий. Правда долго отрабатывает на большом количестве строк. Помогите, пожалуйста его усовершенствовать.
' k - количество строк For i = 2 To k Cells(i, 6).FormulaR1C1 = "=TEXT(RC[-2],""дд.ММ.гггг"")" Cells(i + 1, 6).NumberFormat = "m/d/yyyy" Cells(i + 1, 6).FormulaR1C1 = "=DATEVALUE(LEFT(R[-1]C,10))" If IsDate(Cells(i + 1, 6)) Then s = CLng(Date - CDate(Cells(i + 1, 6))) / 365 If s >= 90 Then Cells(i, 4).Interior.ColorIndex = 3 If s <= 14 Then Cells(i, 4).Interior.ColorIndex = 3 Cells(i, 6).Copy Cells(i, 4).PasteSpecial Paste:=xlPasteValues Else Cells(i, 4).Interior.ColorIndex = 6 End If Next i Range(Cells(2, 6), Cells(k + 1, 6)).Delete Shift:=xlUp
Я бы посоветовал не надеяться на возможности автоформата Excel. Ну и совершенно незачем задействовать ячейки листа для расчетов и копирования - именно это и "тормозит" код (плюс - "перерисовка" значений на листе). Попробуйте как-то так, как показано в файле. Что делать с датами типа "05/15/65" (преобразуемыми в #15.05.1965#) - уже на ваше усмотрение, можно и их отмечать как "неверные"
Я бы посоветовал не надеяться на возможности автоформата Excel. Ну и совершенно незачем задействовать ячейки листа для расчетов и копирования - именно это и "тормозит" код (плюс - "перерисовка" значений на листе). Попробуйте как-то так, как показано в файле. Что делать с датами типа "05/15/65" (преобразуемыми в #15.05.1965#) - уже на ваше усмотрение, можно и их отмечать как "неверные" AndreTM
Вот я и думал, каким образом не задействовать ячейки. Так на ум ничего не пришло. В вашем варианте есть один нюанс: если опечатался в месяце (вместо 05 написал 15) (строка 7 и строка 12), при этом в дне стоит число <=12, то ваш скрипт меняет месяц и год местами. А это не верно. Именно поэтому для проверки я сначала переводил ячейку в текст, а затем обратно в дату и проверял, является ли полученное значение датой.
Вот я и думал, каким образом не задействовать ячейки. Так на ум ничего не пришло. В вашем варианте есть один нюанс: если опечатался в месяце (вместо 05 написал 15) (строка 7 и строка 12), при этом в дне стоит число <=12, то ваш скрипт меняет месяц и год местами. А это не верно. Именно поэтому для проверки я сначала переводил ячейку в текст, а затем обратно в дату и проверял, является ли полученное значение датой.SNIKKerS
Сообщение отредактировал SNIKKerS - Пятница, 05.09.2014, 12:58
"это не баг" (с) Тем более, что полученное значение и у вас - будет датой, и пройдет проверку, и поменяется тоже, я же вам в предыдущем посте пример приводил. Так что надо все равно дописывать ещё одну проверку на такие "ошибки". Вот как в следующем примере:
"это не баг" (с) Тем более, что полученное значение и у вас - будет датой, и пройдет проверку, и поменяется тоже, я же вам в предыдущем посте пример приводил. Так что надо все равно дописывать ещё одну проверку на такие "ошибки". Вот как в следующем примере:AndreTM
я тожи хачу плюсик :( вариант с регуляркой (часть кода безжалостно стырил у AndreTM)
[vba]
Код
Sub test2() Dim r As Range, re As Object, m As Object, c As Range, s0&, s1&, s2&, d, y&
Set re = CreateObject("vbscript.regexp"): re.Pattern = "(\d\d?)[-.,/](\d\d?)[-.,/](\d\d(?:\d\d)?)" With Sheets("Лист1"): Set r = Intersect(.Columns(4), .UsedRange): End With Set r = r.Offset(1).Resize(r.Rows.Count - 1, 1) Application.ScreenUpdating = False r.Interior.ColorIndex = xlAuto: r.Offset(, 4).ClearContents
For Each c In r.Cells Set m = re.Execute(c.Text) If m.Count Then s0 = --m(0).submatches(0): s1 = --m(0).submatches(1): s2 = --m(0).submatches(2) d = DateSerial(s2, s1, s0) If Format(d, "DD-MM-YY") = Format(s0, "00-") & Format(s1, "00-") & Right(Format(s2, "0000"), 2) Then y = DateDiff("yyyy", d, Date): If y>=14 And y<=90 Then c.Offset(, 4) = d Else c.Interior.ColorIndex = 3 Else c.Interior.ColorIndex = 6 End If End If Next End Sub
[/vba]
я тожи хачу плюсик :( вариант с регуляркой (часть кода безжалостно стырил у AndreTM)
[vba]
Код
Sub test2() Dim r As Range, re As Object, m As Object, c As Range, s0&, s1&, s2&, d, y&
Set re = CreateObject("vbscript.regexp"): re.Pattern = "(\d\d?)[-.,/](\d\d?)[-.,/](\d\d(?:\d\d)?)" With Sheets("Лист1"): Set r = Intersect(.Columns(4), .UsedRange): End With Set r = r.Offset(1).Resize(r.Rows.Count - 1, 1) Application.ScreenUpdating = False r.Interior.ColorIndex = xlAuto: r.Offset(, 4).ClearContents
For Each c In r.Cells Set m = re.Execute(c.Text) If m.Count Then s0 = --m(0).submatches(0): s1 = --m(0).submatches(1): s2 = --m(0).submatches(2) d = DateSerial(s2, s1, s0) If Format(d, "DD-MM-YY") = Format(s0, "00-") & Format(s1, "00-") & Right(Format(s2, "0000"), 2) Then y = DateDiff("yyyy", d, Date): If y>=14 And y<=90 Then c.Offset(, 4) = d Else c.Interior.ColorIndex = 3 Else c.Interior.ColorIndex = 6 End If End If Next End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
:( 
