VBA вставка недостающих цифр

Sub Макрос1()
'
' Макрос1 Макрос
'
' Сочетание клавиш: Ctrl+z
'
    Dim ra As Range, delra As Range
    Application.ScreenUpdating = False
    Range("C:C,D:D,E:E,F:F,H:H,J:J").Delete Shift:=xlToLeft
    Columns("A:B").ColumnWidth = 18
    Columns("C:C").ColumnWidth = 20
    Columns("D:D").ColumnWidth = 28
    Columns("E:E").ColumnWidth = 7
    Columns("F:F").ColumnWidth = 12
    r = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    Range("A1:F1").Font.Size = 11
    With Rows("1:1")
        .RowHeight = 48
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Range(Cells(1, 1), Cells(r, 6)).Borders.LineStyle = xlContinuous
    Range("A3:F1048576").Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    'Перенос столбцов.
    Columns("D:E").Cut
    Columns("A:A").Insert Shift:=xlToRight
    Columns("E:E").Cut
    Columns("G:G").Insert Shift:=xlToRight
    Range("A1").Select
    'Удаление строк.
    ТекстДляПоиска = "Снят"    ' удаляем строки с таким текстом
 
    ' перебираем все строки в используемом диапазоне листа
    For Each ra In ActiveSheet.UsedRange.Rows
        ' если в строке найден искомый текст
        If Not ra.Find(ТекстДляПоиска, , xlValues, xlPart) Is Nothing Then
            ' добавляем строку в диапазон для удаления
            If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
        End If
    Next
    ' если подходящие строки найдены - удаляем их
    If Not delra Is Nothing Then delra.EntireRow.Delete
    Range("F:F").Delete Shift:=xlToLeft
    
    'Заголовок.
    Rows("1:3").Insert Shift:=xlDown
    Range("A1") = "Отчет по работе водителей"
    Range("C2") = "7/5/2016 10:00"
    Range("D2") = "7/6/2016 10:00"
    'Выравнивание заголовка
    With Range("A1:E1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Merge
        With .Font
            .Name = "Calibri"
            .Size = 14
            .ThemeColor = xlThemeColorLight1
            .ThemeFont = xlThemeFontMinor
            .Bold = True
        End With
    End With
 
    Range("B2") = "с/по"
    Range("B2").Font.Bold = True
    With Range("C2:D2")
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
 
    'Название столбцов.
    Range("B4") = "Заявки"
    Range("C4") = "Первая заявка"
    Range("D4") = "Последняя заявка"
    Range("E4") = "Сумма"
    
    Range("D5:D883800").ClearContents
End Sub
Sub Макрос1плюс2()
    Макрос1
    Макрос2
End Sub
Sub Макрос2()
    '
    ' Макрос2 Макрос
    '
    ' Сочетание клавиш: Ctrl+x
    '
    Dim i%, k%, N%, LastRow%, A, MinDate As Date
    Application.ScreenUpdating = False
    'Определение минимальной даты
    LastRow = Cells(Rows.Count, "C").End(xlUp).Row
    A = Range("C5:C" & LastRow).Value
    MinDate = Now + 10000
    For i = 5 To LastRow
        If Cells(i, 3) < MinDate Then MinDate = Cells(i, 3)
    Next
    MinDate = DateAdd("h", 10, Fix(MinDate))
    [C2] = MinDate
    [D2] = MinDate + 1
    'Удаление строк (с датой).
    For i = 5 To LastRow
        If Range("C" & i).Value < Range("C2").Value Or Range("C" & i).Value > Range("D2").Value Then
            If Range("C" & i).Value = "" Then Exit For
            Rows(i).Delete
            i = i - 1
        End If
    Next
    'Новую книгу создавать в середине дела не надо.
    'ActiveSheet.Copy ' Создает новую книгу, дальнейшее происходит в ней
     'Подсчет заказов
    For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        If Cells(r + 1, 1) <> Cells(r, 1) Then
            Cells(r + 1, 2) = N: N = 1
            Cells(r + 1, 4) = lastorder: lastorder = Cells(r, 3)
        Else
            Rows(r + 1).Delete
            N = N + 1
        End If
        If Cells(r, 1) = "Водитель" Then Exit For
    Next r
     'Добавление водителей
    Rows("6:9").Insert Shift:=xlDown
    Range("A6") = "109 Муминджанов Фахриддин"
    Range("A7") = "150 Ли Игорь"
    Range("A8") = "143 Умнов Алексей"
    Range("A9") = "121 Квон Стас"
     'Сортировка таблицы
    Range("A5:F1048576").Sort Key1:=Range("A5"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    'Вставка недостающих номеров с 100 - 199
    For k = 100 To 199
        If Trim$(Cells(k - 95, 1)) <> "" Then
            N = Val(Left(Cells(k - 95, 1), 3))
            If N > k Then
                Rows(k - 95).Insert Shift:=xlDown
                With Cells(k - 95, 1): .NumberFormat = "@": .Value = k: End With
            End If
        End If
    Next k
    'Добавление пустых строк.
    For i = 5 To 500
        If WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, 5))) < 1 Then
            Range(Cells(i, 1), Cells(i, 5)).Select
            Selection.Borders.LineStyle = xlContinuous
            Selection.Borders.Weight = xlThin
            Exit For
        Else
            Range(Cells(i, 1), Cells(i, 5)).Interior.Color = xlNone
        End If
    Next
    Selection.Resize(15, 40).Insert Shift:=xlDown
End Sub