Sub TT()
Dim objC As Range
    For Each objC In Selection.Columns(1).Cells
        Select Case objC.IndentLevel
            Case Is = 0
                objC.EntireRow.OutlineLevel = 1
            Case Is = 1
                objC.EntireRow.OutlineLevel = 2
            Case Is = 3
                objC.EntireRow.OutlineLevel = 3
        End Select
    Next objC
End Sub

Sub TT()
    Dim arrIn, arrOut, lngI As Long, lngJ As Long
    Dim wsIn As Worksheet, wsOut As Worksheet 'чисто для сокращения букв кода
    Set wsIn = Worksheets("BAZA"): Set wsOut = Worksheets("ЖурналУчета")
    'пишем в исходный массив данные с листа BAZA
    arrIn = wsIn.Range("A1").CurrentRegion.Value
    'переопределяем размерность выходного массива данных. Сколько в нем строк может получиться не знаем,
    'поэтому определяем столько же, сколько в исходном. А столбцов нужно 6
    ReDim arrOut(1 To UBound(arrIn, 1), 1 To 6)
    'пущщаем цикл по исходному массиву, со второй строки до упора, ищем значение номер контракта на листе Журнал
    For lngI = 2 To UBound(arrIn, 1)
        'Если номер контракта не заполнен в базе - ругаемся и выходим
        If IsEmpty(arrIn(lngI, 2)) Then
            MsgBox "Не заполнен номер контракта, а надо бы!"
            Exit Sub
        End If
        'если номера контракта нет на листе ЖурналУчета (поиск = Nothing)
        If wsOut.UsedRange.Columns(2).Find(arrIn(lngI, 2)) Is Nothing Then
            lngJ = lngJ + 1 'увеличиваем счетчик строк выходного массива и пишем в выходной массив данные из строки исходного массива
            arrOut(lngJ, 2) = arrIn(lngI, 2): arrOut(lngJ, 3) = arrIn(lngI, 6): arrOut(lngJ, 4) = arrIn(lngI, 3)
            arrOut(lngJ, 5) = arrIn(lngI, 4): arrOut(lngJ, 6) = arrIn(lngI, 5)
        End If
    Next lngI
    With wsOut 'на листе ЖурналУчета
        'находим последнюю заполненную ячейку по столбцу 1 (метод End), смещаемся на 1 ячейку вниз (Offset), 
        'и вставляем туда данные выходного массива
        'чтобы все данные влезли, переопределяем область вставки через Resize
        .Range("A3").End(xlDown).Offset(1, 0).Resize(lngJ, 6) = arrOut
        'серийно заполняем номер пп в столбце А стандартным инструментом арифметическая 
        'прогрессия (Главная - Заполнить - прогрессия) с шагом 1
        .Range("A4") = 1
        .Range("A4:A" & .Range("C3").End(xlDown).Row).DataSeries rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Trend:=False
        'получаем красиво пронумерованный журнал
    End With
        'вставлено на всякий случай, поскольку макрос можно запускать с любого листа, а на результат посмотреть надо.
        'если не нужно  - удалить, или закомментировать.
        wsOut.Activate
        Range("A3").Select
End Sub