Option Explicit

Sub ManipulateWithData()
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Worksheets(2)
    Dim lastRow     As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim i           As Long
    Dim rng         As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    With ws
        Set rng = .Range("A2:A" & lastRow)
        .Columns("B:B").Resize(, 3).Insert Shift:=xlToRight
        .Cells(1, 2).Value = "ФИО"
        .Cells(1, 3).Value = "БИН"
        .Cells(1, 4).Value = "Договор"

        For i = 1 To rng.Rows.Count

            If rng.Cells(i, 1).Value Like "*ООО" Then
                rng.Cells(i, 1).Offset(1, 0).Copy rng.Cells(i, 2)
                rng.Cells(i, 1).Offset(2, 0).Copy rng.Cells(i, 3)
                rng.Cells(i, 1).Offset(3, 0).Copy rng.Cells(i, 4)

                rng.Cells(i, 1).Offset(3, 0).EntireRow.Delete
                rng.Cells(i, 1).Offset(2, 0).EntireRow.Delete
                rng.Cells(i, 1).Offset(1, 0).EntireRow.Delete
            End If

        Next i

        .Cells.Columns.AutoFit
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

=ГСТОЛБИК(СВЕРНСТРОК(исходник!A2:A25;4);УНИК(исходник!B2:E25))

Option Explicit

Sub ManipulateData()
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Worksheets(2)
    Dim lastRow     As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim lastCol     As Long: lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Dim rng         As Range: Set rng = ws.Range("A2:A" & lastRow)
    Dim i           As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    If lastCol = 5 Then

        With ws
            .Columns("B:B").Resize(, 3).Insert Shift:=xlToRight
            .Cells(1, 2).Value = "ФИО"
            .Cells(1, 3).Value = "БИН"
            .Cells(1, 4).Value = "Договор"

            For i = 1 To rng.Rows.Count

                If rng.Cells(i, 1).Value Like "*ООО" _
                        Or rng.Cells(i, 1).Value Like "*ИП" Then
                    rng.Cells(i, 1).Offset(1, 0).Copy rng.Cells(i, 2)
                    rng.Cells(i, 1).Offset(2, 0).Copy rng.Cells(i, 3)
                    rng.Cells(i, 1).Offset(3, 0).Copy rng.Cells(i, 4)

                    rng.Cells(i, 1).Offset(3, 0).EntireRow.Delete
                    rng.Cells(i, 1).Offset(2, 0).EntireRow.Delete
                    rng.Cells(i, 1).Offset(1, 0).EntireRow.Delete
                End If

            Next i

            .Cells.Columns.AutoFit
        End With

    Else
        MsgBox "Данные на листе уже реорганизованы! ", vbCritical
        Exit Sub
    End If

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

If rng.Cells(i, 1).Value Like "*ООО" Or rng.Cells(i, 1).Value Like "*ИП" Then

let
    from = Excel.CurrentWorkbook(){[Name="TDSheet"]}[Content],
    nms={"Организация","ФИО","БИН","Договор"}&List.Skip(Table.ColumnNames(from)),
    lst=List.Zip({List.Split(from[Организация],4),List.Alternate(Table.ToList(from,List.Skip),3,1,1)}),
    to = Table.FromList(lst,List.Combine,nms)
in
    to

=IF(COLUMNS($A10:A10)>8;"";INDEX(исходник!$A:$E;IF(COLUMNS($A10:A10)>4;INT((COLUMN(A1)-1)/4)+ROW(A1)*4-3;1+MOD(COLUMN(A1);5)+ROW(A1)*4-4);MOD(MOD(MOD(MOD(COLUMN(A1)-4;8);7);6);5)+1))