Форум по VBA и MS Office

Sub uuu()
    Dim a()
    Dim i&
    Dim sp_date, sp_day
    Dim d1$, d2$, m$, y$
'-------------------------
    Application.ScreenUpdating = False
    With ActiveSheet
        a = .UsedRange.Value
        For i = 1 To UBound(a)
            If a(i, 1) <> "" Then
                sp_date = Split(a(i, 1), " ")
                sp_day = Split(sp_date(0), "-")
                d1 = sp_day(0)
                d2 = d1
                If UBound(sp_day) > 0 Then d2 = sp_day(1)
                m = sp_date(1)
                y = sp_date(2)
                .Cells(i, 2) = CDate(d1 & " " & m & " " & y)
                .Cells(i, 3) = CDate(d2 & " " & m & " " & y)
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Sub Макрос()

    Dim arr(), src, date1 As Date, date2 As Date
    Dim spl, i As Long
   
   
    '1. Отключение монитора, чтобы ускорить макрос.
    Application.ScreenUpdating = False
   
    '2. Копирование данных из активного листа из области, в которой есть данные и оформление, в массив.
    arr() = ActiveSheet.usedrange.Value
   
    '3. Разбивка дат и запись их в столбцы B, C.
    ' Цикл по первому столбцу массива 'arr'.
    For i = 1 To UBound(arr)
       
        '1) Копируем данные из ячейки в переменную. Может быть это упростит чтения кода.
        src = arr(i, 1)
       
        '2) Если ячейка пустая.
        If src = "" Then
            GoTo metka_NextRow
        End If
       
        '3) Запись дат в переменные.
        'a) Если нет дефиса.
        If InStr(src, "-") = 0 Then
            spl = Split(src, " ")
            date1 = CDate(spl(0) & " " & spl(1) & " " & spl(2))
            date2 = CDate(spl(0) & " " & spl(1) & " " & spl(2))
        'b) Если дефис между цифрами: 1-2 января 2018.
        ElseIf src Like "*#-#*" Then
            HyphenAmongDigits src, date1, date2
        'c) Если дефис в другом месте: 1 января - 1 февраля 2018.
        Else
            HyphenInOtherPlace src, date1, date2
        End If
       
        '4) Копирование данных из переменных в эксель.
        Cells(i, 2) = date1
        Cells(i, 3) = date2
       
metka_NextRow:
    Next i
   
    '4. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

Private Sub HyphenAmongDigits(src, date1 As Date, date2 As Date)

    ' Если дефис между цифрами: 1-2 января 2018.
   
    Dim sp_date, sp_day
   
   
    '1. Разбивка текста на слова по пробелам.
    sp_date = Split(src, " ")
   
    '2. Разбивка первого слова на два слова по дефису.
    sp_day = Split(sp_date(0), "-")
   
    '3. Запись дат в переменые.
    date1 = CDate(sp_day(0) & " " & sp_date(1) & " " & sp_date(2))
    date2 = CDate(sp_day(1) & " " & sp_date(1) & " " & sp_date(2))
   
End Sub

Private Sub HyphenInOtherPlace(src, date1 As Date, date2 As Date)

    ' Если дефис в другом месте: 1 января - 1 февраля 2018.
   
    Dim spl, sp_1st, sp_2nd
   
   
    '1. Разбивка на части по дефису и пробелам, которые окружают дефис.
    spl = Split(src, " - ")
   
    '2. Разбивка первой даты на слова по пробелам.
    sp_1st = Split(spl(0), " ")
   
    '3. Разбивка второй даты на слова по пробелам.
    sp_2nd = Split(spl(1), " ")
   
    '4. Запись дат в переменные.
    date1 = CDate(sp_1st(0) & " " & sp_1st(1) & " " & sp_2nd(2))
    date2 = CDate(sp_2nd(0) & " " & sp_2nd(1) & " " & sp_2nd(2))
   
End Sub