Dim i As Integer, l1 As String, l2 As String

Sub GroupExtract()
With ActiveSheet
For i = 1 To 3171
    If (Cells(i, 4).Value = "") Then
        If (.Rows(i).OutlineLevel > 1) Then
            l2 = Trim(Cells(i, 3).Value)
            ' l1 = Cells(i, 3).Value
        Else
            l2 = ""
            l1 = Trim(Cells(i, 3).Value)
        End If
        
        
    End If
    If (.Rows(i).OutlineLevel > 1 And l2 <> "") Then
            Cells(i, 2).Value = l1 + "/" + l2
        Else
            Cells(i, 2).Value = l1
            
            
    End If
    
Next i
End With
End Sub