Sub TTT()
Dim lr&, i&
lr = Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Cells(Rows.Count, 4).End(xlUp).Row
  On Error Resume Next
  Range("D18:E" & lr2).ClearContents
    For i = 2 To lr
        Cells(i, 3).ClearContents
        If Cells(i, 2).Value <> "о" And Cells(i, 1).Value <> "" Then
        Cells(i, 3).Value = "Долг"
        lr1 = Cells(Rows.Count, 4).End(xlUp).Row
        Cells(lr1 + 1, 4).Value = Cells(i, 1).Value
        Cells(lr1 + 1, 5).Value = Cells(1, 1).Value
        End If
    Next i
End Sub

Sub tt()
    na_ = Range("A" & Rows.Count).End(3).Row - 1
    If na_ = 0 Then Exit Sub
    rd1_ = Range("D" & Rows.Count).End(3).Row
    rd0_ = 18
    dat_ = Range("A1")
    If rd1_ < rd0_ Then
        rd1_ = rd0_
    Else
        Range("D" & rd0_).Resize(rd1_ - rd0_ + 1, 2).ClearContents
    End If
    ar1 = Range("A2").Resize(na_, 3)
    ar2 = Range("A2").Resize(na_, 2)
    For i = 1 To na_
        If ar1(i, 2) <> "о" And ar1(i, 1) <> "" Then
            n_ = n_ + 1
            ar1(i, 3) = "долг"
            ar2(n_, 1) = ar1(i, 1)
            ar2(n_, 2) = dat_
        End If
    Next i
    Range("D" & rd0_).Resize(n_, 2) = ar2
    Range("A2").Resize(na_, 3) = ar1
End Sub