Страницы: 1
RSS
Новый быстрый ввод даты и времени без разделителей
 
Всем добрый день!
Долгое время не требовалось быстрый ввод даты/времени делать, но вот опять понадобилось.
Как и раньше (года 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 - 28.11.2016 15:37:30
 
Обработки ошибок нет
Макрос вылетит с ошибкой, если ввести в ячейку что-то неподходящее, например, 1e307
 
Не вылетит. Строка 10 кода решает эту проблему
Изменено: andrey062006 - 28.11.2016 17:25:35
 
Цитата
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
 
Цитата
andrey062006 написал:
макрос Николая тоже не работает с обработкой нескольких ячеек одновременно
у него ничего не происходит, у вас выдает некорректную ошибку.
я это написал к тому, что можно бы и реализовать, тогда будет
Цитата
Dima S написал:
особых удобств по сравнению с уже указанным макросом

Цитата
исправил, теперь работает и с датами до 1999
но не работает с датами после 2016)))
Изменено: Dima S - 28.11.2016 17:27:18
 
Цитата
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 (исправлена ошибка в коде)
 
Цитата
andrey062006 написал: Работает он с датами после 2016
последний работает, предпоследний - нет.
Цитата
andrey062006 написал: я написал как альтернативу...
так я ж вам и подсказываю "фишку")
тем более что это не так и сложно)
Код
(ByVal r As Range)

...
for each c in r.cells
...

;)
 
Цитата
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 - 28.11.2016 20:50:40
There is no knowledge that is not power
 
SuperCat:
1. goto... остался от старого макроса, который был не на Worksheet_Change и если бы Вы потрудились посмотреть дальнейшие коды, Вы бы обнаружили что все эти goto... я удалил, потому что там тестировал.
2. ОБРАБОТЧИК ОШИБОК ЕСТЬ! читайте внимательно: 9 строка. А в первом посте была 10 строка
Цитата
SuperCat написал:
Потому что Cells(x, r.Column) = v вызывает опять Worksheet_Change
Вот за это спасибо. Забыл про это)
Изменено: andrey062006 - 28.11.2016 20:52:17
 
Цитата
SuperCat написал: обработчик Вы добавили ПОСЛЕ того, как Вам указали
Обработчик был еще в первом коде!

Цитата
SuperCat написал: Excel умный, и он прерывает эти многочисленные вызовы
Не прерывает. Если код не остановить он будет выполняться до бесконечности пока приложение не зависнет и не придется закрывать его в диспетчере.
Изменено: andrey062006 - 28.11.2016 20:50:04
 
Цитата
andrey062006 написал: да уж, не сложно)
Таки не сложно, просто вы че то не в ту степь пошли
Плюс когда используете переменную типа 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
Изменено: Dima S - 29.11.2016 03:07:10
 
Цитата
andrey062006 написал:
Обработчик был еще в первом коде!
НЕ ВИЖУ!
There is no knowledge that is not power
 
Скачал макрос, вставил в файл, ввел 11111. А макрос не работает. :)
Не то, чтобы дату неправильную формирует, а вообще никакую формировать не хочет.
 
Dima S, да уж, я не в ту степь пошел)
Классно отредактировали. Теперь и с диапазонами работает)
Спасибо) ;)
 
RAN, в 3 столбец вводили?
Изменено: andrey062006 - 28.11.2016 20:54:46
 
Каюсь, не доглядел
 
SuperCat, 10 СТРОКА
Или вам нужен конкретно ErrHandler? Зачем его встраивать если и так можно ввести только от 3 до 6 символов и только цифры?
Зациклились? :D
 
andrey062006, Я про то, что обработчик ошибок - это On Error (Resume Next | GoTo SomeLabel). В первом сообщении я этого не увидел, поэтому и спрашиваю - где он?
Изменено: SuperCat - 28.11.2016 21:04:29
There is no knowledge that is not power
 
SuperCat, Зачем обработчик если данные проверяются НА ЧИСЛО? введете цифры с буквами, ничего не будет, цифр  меньше 3 или больше 6 - ничего не будет. Любое другое значение (хоть набор цифр, букв и прочих символов) - ничего не будет!
Чем это не обработчик ошибок? Какие тут могут быть ВООБЩЕ ошибки? Или я должен был в угоду Вам разбавить код абсолютно не нужной строкой?

Макрос работает ТОЛЬКО с числом длиной от 3 до 6 символов. На все остальное он не будет ничего делать! И зачем тут Ваш On Error?

P.S. Обратите внимание на код Николая Павлова, у него "On Error" тоже нет, может и его поучите?
Изменено: andrey062006 - 28.11.2016 21:49:59
 
Ещё раз.
Цитата
andrey062006 написал:
2. ОБРАБОТЧИК ОШИБОК ЕСТЬ! читайте внимательно:  9 строка . А  в первом посте  была 10 строка
Так я и спрашиваю - где обработчик ошибок?
There is no knowledge that is not power
 
Цитата
vikttur написал: Еще раз - и тема будет закрыта. Хватит цапаться!
Да хоть вообще удалите. Один ... тут троллинг развел а я еще и виноват и мою же еще тему закрывать.
Да уж... Какое то однобокое видение у Вас, господин модератор.
 
andrey062006, бан на месяц!
 
andrey062006, если Вы так остро реагируете на критику и колкости форумчан, то лучше не выставляйте на суд свои наработки - этим Вы только испортите себе настроение и отношения с людьми испортите.
И ещё, vikttur написал про закрытие темы не Вам, а SuperCat, если я правильно понял.
Всего Вам доброго.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
А как быть если на листе не по одному столбцу с датой и временем, а по два, три?
Страницы: 1
Наверх