Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Быстрый ввод даты и времени - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Быстрый ввод даты и времени (Макросы/Sub)
Быстрый ввод даты и времени
DrMini Дата: Суббота, 20.04.2019, 08:12 | Сообщение № 1
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
Доброго времени суток Форумчане.
Использовал найденный в Internet`e макрос
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vVal
Dim StrVal As String
Dim dDate As Date

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("D5:D10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
[/vba]
Помогите пожалуйста сделать так, что бы он работал и в колонках "E""F""G""H"
Файл прилагаю
К сообщению приложен файл: 5695763.xlsm (19.8 Kb)
 
Ответить
СообщениеДоброго времени суток Форумчане.
Использовал найденный в Internet`e макрос
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vVal
Dim StrVal As String
Dim dDate As Date

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("D5:D10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
[/vba]
Помогите пожалуйста сделать так, что бы он работал и в колонках "E""F""G""H"
Файл прилагаю
Автор - DrMini
Дата добавления - 20.04.2019 в 08:12
DrMini Дата: Суббота, 20.04.2019, 08:38 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
Сделал методом научного тыка. Получилось вот так:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vVal
Dim StrVal As String
Dim dDate As Date

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("D5:D10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
     
     If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("E5:E10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("F5:F10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
     
     If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("H5:H10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
     Application.EnableEvents = True

End Sub
[/vba]
Работет.
 
Ответить
СообщениеСделал методом научного тыка. Получилось вот так:
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vVal
Dim StrVal As String
Dim dDate As Date

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("D5:D10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
     
     If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("E5:E10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("F5:F10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
     
     If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
        With Target
        StrVal = Format(.Text, "000000")
        If IsNumeric(StrVal) And Len(StrVal) = 6 Then
            Application.EnableEvents = False
            dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(dDate), Month(dDate), Day(dDate)))
           End If
        End With
    End If
     
    If Not Intersect(Target, Range("H5:H10000")) Is Nothing Then
        With Target
            vVal = Format(.Value, "0000")
            If IsNumeric(vVal) And Len(vVal) = 4 Then
                Application.EnableEvents = False
                .Value = Left(vVal, 2) & ":" & Right(vVal, 2)
                .NumberFormat = "[h]:mm"
            End If
        End With
     End If
     Application.EnableEvents = True

End Sub
[/vba]
Работет.
Автор - DrMini
Дата добавления - 20.04.2019 в 08:38
DrMini Дата: Суббота, 20.04.2019, 09:51 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
При ошибке ввода (например всего четырёх цифр) макрос перестаёт работать. Помогает только перезагрузка файла. Так, как этот лист будет в книге состоящей из нескольких листов помогите это исправить. Какой ни будь функцией в макросе не дающей ему прекращать работать или кнопкой для его перезапуска.
[p.s.]Создать новую тему или можно продолжить эту?[/p.s.]
[offtop]Прошу прощения если написал в описании проблемы бред. Я в VBA мягко говоря не силён. Помогите если это возможно.[/offtop]олжить здесь?
 
Ответить
СообщениеПри ошибке ввода (например всего четырёх цифр) макрос перестаёт работать. Помогает только перезагрузка файла. Так, как этот лист будет в книге состоящей из нескольких листов помогите это исправить. Какой ни будь функцией в макросе не дающей ему прекращать работать или кнопкой для его перезапуска.
[p.s.]Создать новую тему или можно продолжить эту?[/p.s.]
[offtop]Прошу прощения если написал в описании проблемы бред. Я в VBA мягко говоря не силён. Помогите если это возможно.[/offtop]олжить здесь?
Автор - DrMini
Дата добавления - 20.04.2019 в 09:51
Pelena Дата: Суббота, 20.04.2019, 11:06 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 19405
Репутация: 4555 ±
Замечаний: ±

Excel 365 & Mac Excel
Продолжайте здесь, если речь по-прежнему про ввод даты и времени

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеПродолжайте здесь, если речь по-прежнему про ввод даты и времени
Автор - Pelena
Дата добавления - 20.04.2019 в 11:06
RAN Дата: Суббота, 20.04.2019, 11:16 | Сообщение № 5
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Мяу
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000,E5:E10000,G5:G10000")) Is Nothing Then
        If Len(Target) = 5 Or Len(Target) = 6 Then
            If IsDate(Format(Target.Value, "00\/00\/00")) Then
                If Mid(Format(Target.Value, "00\/00\/00"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/00"))
                Application.EnableEvents = True
            End If
        ElseIf Len(Target) = 7 Or Len(Target) = 8 Then
            If IsDate(Format(Target.Value, "00\/00\/0000")) Then
                If Mid(Format(Target.Value, "00\/00\/0000"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/0000"))
                Application.EnableEvents = True
            End If
        End If
        ElseIf Not Intersect(Target, Range("D5:D10000,F5:F10000,H5:H10000")) Is Nothing Then
            If Len(Target) = 3 Or Len(Target) = 4 Then
                If IsDate(Format(Format(Target.Value, "00:00"), "h:nn")) Then
                    Application.EnableEvents = False
                    Target = Format(Format(Target.Value, "00:00"), "h:nn")
                    Application.EnableEvents = True
                Else
                    Application.EnableEvents = False
                    Application.Undo
                    Application.EnableEvents = True

                End If
            End If
        End If
        Application.EnableEvents = True
        Exit Sub
error_:
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
    End Sub
[/vba]

Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеМяу
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000,E5:E10000,G5:G10000")) Is Nothing Then
        If Len(Target) = 5 Or Len(Target) = 6 Then
            If IsDate(Format(Target.Value, "00\/00\/00")) Then
                If Mid(Format(Target.Value, "00\/00\/00"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/00"))
                Application.EnableEvents = True
            End If
        ElseIf Len(Target) = 7 Or Len(Target) = 8 Then
            If IsDate(Format(Target.Value, "00\/00\/0000")) Then
                If Mid(Format(Target.Value, "00\/00\/0000"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/0000"))
                Application.EnableEvents = True
            End If
        End If
        ElseIf Not Intersect(Target, Range("D5:D10000,F5:F10000,H5:H10000")) Is Nothing Then
            If Len(Target) = 3 Or Len(Target) = 4 Then
                If IsDate(Format(Format(Target.Value, "00:00"), "h:nn")) Then
                    Application.EnableEvents = False
                    Target = Format(Format(Target.Value, "00:00"), "h:nn")
                    Application.EnableEvents = True
                Else
                    Application.EnableEvents = False
                    Application.Undo
                    Application.EnableEvents = True

                End If
            End If
        End If
        Application.EnableEvents = True
        Exit Sub
error_:
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
    End Sub
[/vba]
Автор - RAN
Дата добавления - 20.04.2019 в 11:16
DrMini Дата: Суббота, 20.04.2019, 16:33 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
RAN, Конечно муррр но не совсем...
Ввожу например вместо 050119 5119 выходит ошибка. И после нажатия на любую из кнопок "Debug" или "End" надо перезагружать файл по новой. При вводе пяти цифр 50119 всё нормально. Ошибка возникает только при вводе от ОДНОЙ до ЧЕТЫРЁХ цифр. Вот как бы избавиться от перезагрузки файла. К нему в локалке подключается изредка ещё один человек (только для чтения) что бы посмотреть данные. Может это как то возможно сделать?
 
Ответить
СообщениеRAN, Конечно муррр но не совсем...
Ввожу например вместо 050119 5119 выходит ошибка. И после нажатия на любую из кнопок "Debug" или "End" надо перезагружать файл по новой. При вводе пяти цифр 50119 всё нормально. Ошибка возникает только при вводе от ОДНОЙ до ЧЕТЫРЁХ цифр. Вот как бы избавиться от перезагрузки файла. К нему в локалке подключается изредка ещё один человек (только для чтения) что бы посмотреть данные. Может это как то возможно сделать?
Автор - DrMini
Дата добавления - 20.04.2019 в 16:33
RAN Дата: Воскресенье, 21.04.2019, 08:47 | Сообщение № 7
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Вы еще АБВГД попробуйте ввести.
По вашему 5119 похоже на дату? По моему нет.

PS И, кстати, при вводе 5119 вводиться именно 5119, без всяких ошибок.

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Воскресенье, 21.04.2019, 08:55
 
Ответить
СообщениеВы еще АБВГД попробуйте ввести.
По вашему 5119 похоже на дату? По моему нет.

PS И, кстати, при вводе 5119 вводиться именно 5119, без всяких ошибок.
Автор - RAN
Дата добавления - 21.04.2019 в 08:47
DrMini Дата: Воскресенье, 21.04.2019, 08:54 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
Цитата RAN, 21.04.2019 в 08:47, в сообщении № 7 ()
Вы еще АБВГД попробуйте ввести.
По вашему 5119 похоже на дату? По моему нет.

Полностью с Вами согласен. Диспетчера будут в течении суток вводить данные и может быть любая ошибка которая остановит выполнение макроса. Хочется исключить перезагрузку файла. Только макрос. Или сделать так, что бы выдавалась ошибка и можно было дальше работать.


Сообщение отредактировал DrMini - Воскресенье, 21.04.2019, 08:58
 
Ответить
Сообщение
Цитата RAN, 21.04.2019 в 08:47, в сообщении № 7 ()
Вы еще АБВГД попробуйте ввести.
По вашему 5119 похоже на дату? По моему нет.

Полностью с Вами согласен. Диспетчера будут в течении суток вводить данные и может быть любая ошибка которая остановит выполнение макроса. Хочется исключить перезагрузку файла. Только макрос. Или сделать так, что бы выдавалась ошибка и можно было дальше работать.
Автор - DrMini
Дата добавления - 21.04.2019 в 08:54
DrMini Дата: Воскресенье, 21.04.2019, 08:57 | Сообщение № 9
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
RAN, И Ваш макрос не работает с 2023 годом и выше. А ведь он (2023 год) не за горами.
 
Ответить
СообщениеRAN, И Ваш макрос не работает с 2023 годом и выше. А ведь он (2023 год) не за горами.
Автор - DrMini
Дата добавления - 21.04.2019 в 08:57
RAN Дата: Воскресенье, 21.04.2019, 09:07 | Сообщение № 10
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Цитата DrMini, 21.04.2019 в 08:57, в сообщении № 9 ()
И Ваш макрос не работает с 2023 годом и выше.

Да неужели?
А если 01012050 ввести?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000,E5:E10000,G5:G10000")) Is Nothing Then
        If Len(Target) = 5 Or Len(Target) = 6 Then
            If IsDate(Format(Target.Value, "00\/00\/00")) Then
                If Mid(Format(Target.Value, "00\/00\/00"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/00"))
                Application.EnableEvents = True
                Else: GoTo error_
            End If
        ElseIf Len(Target) = 7 Or Len(Target) = 8 Then
            If IsDate(Format(Target.Value, "00\/00\/0000")) Then
                If Mid(Format(Target.Value, "00\/00\/0000"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/0000"))
                Application.EnableEvents = True
                Else: GoTo error_
            End If
                Else: GoTo error_
        End If
        ElseIf Not Intersect(Target, Range("D5:D10000,F5:F10000,H5:H10000")) Is Nothing Then
            If Len(Target) = 3 Or Len(Target) = 4 Then
                If IsDate(Format(Format(Target.Value, "00:00"), "h:nn")) Then
                    Application.EnableEvents = False
                    Target = Format(Format(Target.Value, "00:00"), "h:nn")
                    Application.EnableEvents = True
                Else
                    Application.EnableEvents = False
                    Application.Undo
                    Application.EnableEvents = True
                End If
            End If
        End If
        Application.EnableEvents = True
        Exit Sub
error_:
        Application.EnableEvents = False
        Target = Empty ' Punto Switcher, гад, отмене мешает
'        Application.Undo
        Application.EnableEvents = True
    End Sub
[/vba]

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Воскресенье, 21.04.2019, 09:11
 
Ответить
Сообщение
Цитата DrMini, 21.04.2019 в 08:57, в сообщении № 9 ()
И Ваш макрос не работает с 2023 годом и выше.

Да неужели?
А если 01012050 ввести?
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000,E5:E10000,G5:G10000")) Is Nothing Then
        If Len(Target) = 5 Or Len(Target) = 6 Then
            If IsDate(Format(Target.Value, "00\/00\/00")) Then
                If Mid(Format(Target.Value, "00\/00\/00"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/00"))
                Application.EnableEvents = True
                Else: GoTo error_
            End If
        ElseIf Len(Target) = 7 Or Len(Target) = 8 Then
            If IsDate(Format(Target.Value, "00\/00\/0000")) Then
                If Mid(Format(Target.Value, "00\/00\/0000"), 4, 2) > 12 Then GoTo error_
                Application.EnableEvents = False
                Target = CDate(Format(Target.Value, "00\/00\/0000"))
                Application.EnableEvents = True
                Else: GoTo error_
            End If
                Else: GoTo error_
        End If
        ElseIf Not Intersect(Target, Range("D5:D10000,F5:F10000,H5:H10000")) Is Nothing Then
            If Len(Target) = 3 Or Len(Target) = 4 Then
                If IsDate(Format(Format(Target.Value, "00:00"), "h:nn")) Then
                    Application.EnableEvents = False
                    Target = Format(Format(Target.Value, "00:00"), "h:nn")
                    Application.EnableEvents = True
                Else
                    Application.EnableEvents = False
                    Application.Undo
                    Application.EnableEvents = True
                End If
            End If
        End If
        Application.EnableEvents = True
        Exit Sub
error_:
        Application.EnableEvents = False
        Target = Empty ' Punto Switcher, гад, отмене мешает
'        Application.Undo
        Application.EnableEvents = True
    End Sub
[/vba]
Автор - RAN
Дата добавления - 21.04.2019 в 09:07
DrMini Дата: Воскресенье, 21.04.2019, 09:18 | Сообщение № 11
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
Андрей не обижайтесь. Правда выдавалась ошибка. Теперь нет.
 
Ответить
СообщениеАндрей не обижайтесь. Правда выдавалась ошибка. Теперь нет.
Автор - DrMini
Дата добавления - 21.04.2019 в 09:18
DrMini Дата: Воскресенье, 21.04.2019, 09:21 | Сообщение № 12
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
И не правильные даты просто не вводятся. Спасибо Вам. Вроде то, что надо. Сегодня гонят меня на огород копать. Вечером буду тестировать.
[p.s.]СПАСИБО[/p.s.]


Сообщение отредактировал DrMini - Воскресенье, 21.04.2019, 18:21
 
Ответить
СообщениеИ не правильные даты просто не вводятся. Спасибо Вам. Вроде то, что надо. Сегодня гонят меня на огород копать. Вечером буду тестировать.
[p.s.]СПАСИБО[/p.s.]
Автор - DrMini
Дата добавления - 21.04.2019 в 09:21
DrMini Дата: Среда, 24.04.2019, 14:01 | Сообщение № 13
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
В продолжении этой и вот этой тем. Помогите пожалуйста "подружить" макросы на одном листе.

[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000,E5:E10000,G5:G10000")) Is Nothing Then
        If Target.NumberFormat = "m/d/yyyy" Then
            Target.NumberFormat = "General"
        End If
        x_ = Target
        If Len(x_) = 5 Or Len(x_) = 6 Then
            If IsDate(Format(x_, "00\/00\/00")) Then
                If Mid(Format(x_, "00\/00\/00"), 4, 2) > 12 Then GoTo error_
                x_ = CDate(Format(x_, "00\/00\/00"))
            Else: GoTo error_
            End If
        ElseIf Len(x_) = 7 Or Len(x_) = 8 Then
            If IsDate(Format(x_, "00\/00\/0000")) Then
                If Mid(Format(x_, "00\/00\/0000"), 4, 2) > 12 Then GoTo error_
                x_ = CDate(Format(x_, "00\/00\/0000"))
            Else: GoTo error_
            End If
        Else: GoTo error_
        End If
        Application.EnableEvents = False
        Target = x_
        Application.EnableEvents = True
        ElseIf Not Intersect(Target, Range("D5:D10000,F5:F10000,H5:H10000")) Is Nothing Then
            If Len(Target) = 3 Or Len(Target) = 4 Then
                If IsDate(Format(Format(Target.Value, "00:00"), "h:nn")) Then
                    Application.EnableEvents = False
                    Target = Format(Format(Target.Value, "00:00"), "h:nn")
                    Application.EnableEvents = True
                Else
                    Application.EnableEvents = False
                    Application.Undo
                    Application.EnableEvents = True
                End If
            End If
        End If
        Application.EnableEvents = True
        Exit Sub
error_:
        Application.EnableEvents = False
        Target = Empty ' Punto Switcher, гад, отмене мешает
'        Application.Undo
        Application.EnableEvents = True
    End Sub
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim d0_ As Range
    Set d_ = Intersect(Target, Range("J5:J2000")) 'диапазон
    If Not d_ Is Nothing Then
        Application.ScreenUpdating = 0
        Application.EnableEvents = 0
        On Error Resume Next
        With d_
            For Each d0_ In d_
                d0_ = --Right(d0_, 10)
                d0_.NumberFormat = "[<=9999999]#-##-##;+7(###) ###-##-##"
            Next d0_
        End With
        Application.EnableEvents = 1
        Application.ScreenUpdating = 1
    End If
End Sub
[/vba]Файл прилагаю.
К сообщению приложен файл: Dispatcher4__.zip (64.7 Kb)
 
Ответить
СообщениеВ продолжении этой и вот этой тем. Помогите пожалуйста "подружить" макросы на одном листе.

[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("C5:C10000,E5:E10000,G5:G10000")) Is Nothing Then
        If Target.NumberFormat = "m/d/yyyy" Then
            Target.NumberFormat = "General"
        End If
        x_ = Target
        If Len(x_) = 5 Or Len(x_) = 6 Then
            If IsDate(Format(x_, "00\/00\/00")) Then
                If Mid(Format(x_, "00\/00\/00"), 4, 2) > 12 Then GoTo error_
                x_ = CDate(Format(x_, "00\/00\/00"))
            Else: GoTo error_
            End If
        ElseIf Len(x_) = 7 Or Len(x_) = 8 Then
            If IsDate(Format(x_, "00\/00\/0000")) Then
                If Mid(Format(x_, "00\/00\/0000"), 4, 2) > 12 Then GoTo error_
                x_ = CDate(Format(x_, "00\/00\/0000"))
            Else: GoTo error_
            End If
        Else: GoTo error_
        End If
        Application.EnableEvents = False
        Target = x_
        Application.EnableEvents = True
        ElseIf Not Intersect(Target, Range("D5:D10000,F5:F10000,H5:H10000")) Is Nothing Then
            If Len(Target) = 3 Or Len(Target) = 4 Then
                If IsDate(Format(Format(Target.Value, "00:00"), "h:nn")) Then
                    Application.EnableEvents = False
                    Target = Format(Format(Target.Value, "00:00"), "h:nn")
                    Application.EnableEvents = True
                Else
                    Application.EnableEvents = False
                    Application.Undo
                    Application.EnableEvents = True
                End If
            End If
        End If
        Application.EnableEvents = True
        Exit Sub
error_:
        Application.EnableEvents = False
        Target = Empty ' Punto Switcher, гад, отмене мешает
'        Application.Undo
        Application.EnableEvents = True
    End Sub
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim d0_ As Range
    Set d_ = Intersect(Target, Range("J5:J2000")) 'диапазон
    If Not d_ Is Nothing Then
        Application.ScreenUpdating = 0
        Application.EnableEvents = 0
        On Error Resume Next
        With d_
            For Each d0_ In d_
                d0_ = --Right(d0_, 10)
                d0_.NumberFormat = "[<=9999999]#-##-##;+7(###) ###-##-##"
            Next d0_
        End With
        Application.EnableEvents = 1
        Application.ScreenUpdating = 1
    End If
End Sub
[/vba]Файл прилагаю.
Автор - DrMini
Дата добавления - 24.04.2019 в 14:01
_Boroda_ Дата: Среда, 24.04.2019, 14:30 | Сообщение № 14
Группа: Админы
Ранг: Местный житель
Сообщений: 16718
Репутация: 6505 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
Ловите
К сообщению приложен файл: Dispatcher_1.xlsb (44.9 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЛовите
Автор - _Boroda_
Дата добавления - 24.04.2019 в 14:30
DrMini Дата: Среда, 24.04.2019, 15:01 | Сообщение № 15
Группа: Друзья
Ранг: Старожил
Сообщений: 1880
Репутация: 269 ±
Замечаний: 0% ±

Excel LTSC 2024 RUS
Александр. Спасибо Вам огромное. Всё работает. Жалко, что рейтинг Вам добавить сегодня больше не могу.
 
Ответить
СообщениеАлександр. Спасибо Вам огромное. Всё работает. Жалко, что рейтинг Вам добавить сегодня больше не могу.
Автор - DrMini
Дата добавления - 24.04.2019 в 15:01
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Быстрый ввод даты и времени (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!