Всем добрый день! Долгое время не требовалось быстрый ввод даты/времени делать, но вот опять понадобилось. Как и раньше (года 3 назад) хотел взять макрос Николая Павлова, но все таки решил написать свой. Вдруг кому-то пригодится. Буду рад комментариям и конструктивной критике) DR - диапазон даты TR - диапазон времени
Код
Private Sub Worksheet_Change(ByVal c As Range)
Dim DR As Range, TR As Range
Dim S As String, k As String
Dim m&
If c.Row = 1 Then GoTo EM
Set DR = Columns(3)
Set TR = Columns(4)
S = Left(Year(Date), 2)
If c.Column = 3 Then k = "Date format is not dmmyyyy" Else: If c.Column = 4 Then k = "Time format is not hmm" Else GoTo EM
If IsNumeric(c) Then
If Len(c) = 6 Or Len(c) = 5 Then If Len(c) = 6 Then m = 3 Else m = 2
If Len(c) = 4 Or Len(c) = 3 Then If Len(c) = 4 Then m = 2 Else m = 1
If Not Intersect(c, DR) Is Nothing And Len(c) = 6 Or Len(c) = 5 Then c = DateSerial(CDbl(S & Right(c, 2)), CDbl(Mid(c, m, 2)), CDbl(Left(c, m - 1))): GoTo EM
If Not Intersect(c, TR) Is Nothing And Len(c) = 4 Or Len(c) = 3 Then c = Format(TimeSerial(CDbl(Left(c, m)), CDbl(Right(c, 2)), 0), "h:mm")
Else
If IsDate(c) Then GoTo EM
MsgBox k, vbExclamation + vbOKOnly, "ERROR"
End If
EM:
Set c = Nothing
End Sub
andrey062006 написал: Буду рад комментариям и конструктивной критике
не работает, если год введен 4-мя цифрами, соответственно, можно вводить даты только после 1999 года некорректная обработка одновременного ввода в несколько ячеек
а так - особых удобств по сравнению с уже указанным макросом не нашел
ну, знаете ли, макрос Николая тоже не работает с обработкой нескольких ячеек одновременно у него тоже можно только 1 ячейку изменить а по поводу только после 1999, согласен... исправил, теперь работает и с датами до 1999
Код
Private Sub Worksheet_Change(ByVal c As Range)
Dim DR As Range, TR As Range
Dim S As String, k As String, kk As Variant
Dim m&
If c.Row = 1 Then GoTo EM
Set DR = Columns(3)
Set TR = Columns(4)
If CDbl(Right(Year(Date), 2)) + 12 < CDbl(Right(c, 2)) Then kk = -1 Else kk = 0
S = Left(Year(Date), 2) + kk
If c.Column = 3 Then k = "Date format is not dmmyyyy" Else: If c.Column = 4 Then k = "Time format is not hmm" Else GoTo EM
If IsNumeric(c) Then
If Len(c) = 6 Or Len(c) = 5 Then If Len(c) = 6 Then m = 3 Else m = 2
If Len(c) = 4 Or Len(c) = 3 Then If Len(c) = 4 Then m = 2 Else m = 1
If Not Intersect(c, DR) Is Nothing And Len(c) = 6 Or Len(c) = 5 Then c = DateSerial(CDbl(S & Right(c, 2)), CDbl(Mid(c, m, 2)), CDbl(Left(c, m - 1))): GoTo EM
If Not Intersect(c, TR) Is Nothing And Len(c) = 4 Or Len(c) = 3 Then c = Format(TimeSerial(CDbl(Left(c, m)), CDbl(Right(c, 2)), 0), "h:mm")
Else
If IsDate(c) Then GoTo EM
MsgBox k, vbExclamation + vbOKOnly, "ERROR"
End If
EM:
Set c = Nothing
End Sub
Dima S написал: у него ничего не происходит, у вас выдает некорректную ошибку.
Есть такое дело, исправил:
Код
Private Sub Worksheet_Change(ByVal c As Range)
Dim DR As Range, TR As Range
Dim S As String, k As String, kk As Variant
Dim m&
If c.Row = 1 Or c.Cells.Count > 1 Then Exit Sub
Set DR = Columns(3)
Set TR = Columns(4)
If c.Column = 3 Then k = "Date format is not dmmyy" Else: If c.Column = 4 Then k = "Time format is not hmm" Else Exit Sub
If IsNumeric(c) Then
If CDbl(Right(Year(Date), 2)) + 12 < CDbl(Right(c, 2)) Then kk = -1 Else kk = 0
S = Left(Year(Date), 2) + kk
If Len(c) = 6 Or Len(c) = 5 Then If Len(c) = 6 Then m = 3 Else m = 2
If Len(c) = 4 Or Len(c) = 3 Then If Len(c) = 4 Then m = 2 Else m = 1
If Not Intersect(c, DR) Is Nothing And Len(c) = 6 Or Len(c) = 5 Then c = DateSerial(CDbl(S & Right(c, 2)), CDbl(Mid(c, m, 2)), CDbl(Left(c, m - 1))): Exit Sub
If Not Intersect(c, TR) Is Nothing And Len(c) = 4 Or Len(c) = 3 Then c = Format(TimeSerial(CDbl(Left(c, m)), CDbl(Right(c, 2)), 0), "h:mm")
Else
If IsDate(c) Then Exit Sub
MsgBox k, vbExclamation + vbOKOnly, "ERROR"
End If
End Sub
Цитата
Dima S написал: но не работает с датами после 2016)))
Работает он с датами после 2016, только что проверил, все работает.
Цитата
Dima S написал: а так - особых удобств по сравнению с уже указанным макросом не нашел
я написал как альтернативу...
Изменено: andrey062006 - 28.11.2016 20:52:59(исправлена ошибка в коде)
Dima S написал: тем более что это не так и сложно)
да уж, не сложно) попробовал, для дат работает, для времени нет и почему то каждый раз возвращается в начало макроса
Код
Private Sub Worksheet_Change(ByVal r As Range)
Dim DR As Range, TR As Range, c As String
Dim S As String, k As String, kk As Variant
Dim v As Variant
Dim m&, z&, x&
c = Cells(r.Row, r.Column)
Set DR = Columns(3)
Set TR = Columns(4)
If r.Column = 3 Then k = "Date format is not dmmyy" Else: If r.Column = 4 Then k = "Time format is not hmm" Else Exit Sub
If IsNumeric(c) Then
If c >= 5 Then If Right(Year(Date), 2) + 12 < CDbl(Right(c, 2)) Then kk = -1 Else kk = 0
S = Left(Year(Date), 2) + kk
If Len(c) = 6 Or Len(c) = 5 Then If Len(c) = 6 Then m = 3 Else m = 2
If Len(c) = 4 Or Len(c) = 3 Then If Len(c) = 4 Then m = 2 Else m = 1
If Not Intersect(Cells(r.Row, r.Column), DR) Is Nothing And Len(c) = 6 Or Len(c) = 5 Then v = DateSerial(CDbl(S & Right(c, 2)), CDbl(Mid(c, m, 2)), CDbl(Left(c, m - 1)))
If Not Intersect(Cells(r.Row, r.Column), TR) Is Nothing And Len(c) = 4 Or Len(c) = 3 Then v = Format(TimeSerial(CDbl(Left(c, m)), CDbl(Right(c, 2)), 0), "h:mm")
For x = r.Row To r.Row + r.Count - 1
Cells(x, r.Column) = v
Next
Exit Sub
Else
If IsDate(c) Then Exit Sub
MsgBox k, vbExclamation + vbOKOnly, "ERROR"
End If
End Sub
Хотите критики? Их есть у меня. 1. GoTo EM => Set c = Nothing. Это для чего? Зачем это нужно, когда Excel всё сам сделает Nothing? 2. Нет обработчика ошибок от слова совсем. 3.
Цитата
andrey062006 написал: и почему то каждый раз возвращается в начало макроса
Потому что Cells(x, r.Column) = v вызывает опять Worksheet_Change.
SuperCat: 1. goto... остался от старого макроса, который был не на Worksheet_Change и если бы Вы потрудились посмотреть дальнейшие коды, Вы бы обнаружили что все эти goto... я удалил, потому что там тестировал. 2. ОБРАБОТЧИК ОШИБОК ЕСТЬ! читайте внимательно: 9 строка. А в первом посте была 10 строка
Цитата
SuperCat написал: Потому что Cells(x, r.Column) = v вызывает опять Worksheet_Change
Таки не сложно, просто вы че то не в ту степь пошли Плюс когда используете переменную типа Range - нужно четко указывать какое именно ее свойство вы хотите получить, а то Len( c ) может дать совершенно не тот результат, который вы ожыдаете. Вот - поубирал лишнее
Код
Private Sub Worksheet_Change(ByVal r As Range)
Dim DR As Range, TR As Range, c As Range
Dim S As String, k As String, kk As Variant
Dim m&
On Error GoTo erh
Application.EnableEvents = False
Set DR = Columns(3)
Set TR = Columns(4)
For Each c In r.Cells
With c
If .Row = 1 Then Exit Sub
If IsNumeric(.Value2) Then
If CDbl(Right(Year(Date), 2)) + 12 < CDbl(Right(.Value2, 2)) Then kk = -1 Else kk = 0
S = Left(Year(Date), 2) + kk
If Len(.Value2) = 6 Or Len(.Value2) = 5 Then If Len(.Value2) = 6 Then m = 3 Else m = 2
If Len(.Value2) = 4 Or Len(.Value2) = 3 Then If Len(.Value2) = 4 Then m = 2 Else m = 1
If Not Intersect(c, DR) Is Nothing And Len(.Value2) = 6 Or Len(.Value2) = 5 Then .Value = DateSerial(CDbl(S & Right(.Value2, 2)), CDbl(Mid(.Value2, m, 2)), CDbl(Left(.Value2, m - 1)))
If Not Intersect(c, TR) Is Nothing And Len(.Value2) = 4 Or Len(.Value2) = 3 Then .Value = Format(TimeSerial(CDbl(Left(.Value2, m)), CDbl(Right(.Value2, 2)), 0), "h:mm")
End If
End With
Next
erh:
Application.EnableEvents = True
End Sub
SuperCat, 10 СТРОКА Или вам нужен конкретно ErrHandler? Зачем его встраивать если и так можно ввести только от 3 до 6 символов и только цифры? Зациклились?
andrey062006, Я про то, что обработчик ошибок - это On Error (Resume Next | GoTo SomeLabel). В первом сообщении я этого не увидел, поэтому и спрашиваю - где он?
SuperCat, Зачем обработчик если данные проверяются НА ЧИСЛО? введете цифры с буквами, ничего не будет, цифр меньше 3 или больше 6 - ничего не будет. Любое другое значение (хоть набор цифр, букв и прочих символов) - ничего не будет! Чем это не обработчик ошибок? Какие тут могут быть ВООБЩЕ ошибки? Или я должен был в угоду Вам разбавить код абсолютно не нужной строкой?
Макрос работает ТОЛЬКО с числом длиной от 3 до 6 символов. На все остальное он не будет ничего делать! И зачем тут Ваш On Error?
P.S. Обратите внимание на код Николая Павлова, у него "On Error" тоже нет, может и его поучите?
vikttur написал: Еще раз - и тема будет закрыта. Хватит цапаться!
Да хоть вообще удалите. Один ... тут троллинг развел а я еще и виноват и мою же еще тему закрывать. Да уж... Какое то однобокое видение у Вас, господин модератор.
andrey062006, если Вы так остро реагируете на критику и колкости форумчан, то лучше не выставляйте на суд свои наработки - этим Вы только испортите себе настроение и отношения с людьми испортите. И ещё, vikttur написал про закрытие темы не Вам, а SuperCat, если я правильно понял. Всего Вам доброго.
Формула массива (ФМ) вводится Ctrl+Shift+Enter Memento mori