Sub ertert()
Dim x, y(), sp, i&, j&, k&, n&

With Sheets("Лист1")
    If .FilterMode Then .ShowAllData
    With .Range("A1").CurrentRegion
        x = .Value: .ClearContents
    End With

    For j = 1 To UBound(x, 2)
        ReDim y(1 To UBound(x), 1 To 1): k = 1

        For i = 1 To UBound(x)
            sp = Split(x(i, j), "\")
            If UBound(sp) + 1 > k Then
                k = UBound(sp) + 1
                ReDim Preserve y(1 To UBound(x), 1 To k)
                y(1, k) = x(1, j)
            End If
            For n = 0 To UBound(sp)
                y(i, n + 1) = sp(n)
            Next n
        Next i

        n = .Cells(1, Columns.Count).End(xlToLeft).Column
        If j > 1 Then n = n + 1
        .Cells(1, n).Resize(UBound(y, 1), UBound(y, 2)).Value = y
    Next j
End With
End Sub