Option Explicit

Sub tt()
     Dim r As Range, c As Range, nr$, nz$, i&

     Set r = ActiveSheet.UsedRange
     ReDim a(1 To r.Rows.Count, 1 To 4)

     For Each c In r.Columns(1).Cells
         If c.Interior.ColorIndex = 19 Then
             If c.Font.Bold Then nr = c.Value: nz = c.Offset(1).Value
         Else
             If Not c.Font.Bold Then
                 If Len(c.Offset(, 1)) Then
                     i = i + 1
                     a(i, 1) = nr
                     a(i, 2) = nz
                     a(i, 3) = c
                     a(i, 4) = c.Offset(, 1)
                 End If
             End If
         End If
     Next

     [e1].Resize(i, 4) = a
End Sub