Sub rediz()
Dim i As Long, n As Long, lr As Long, d As Long
Dim sh As Worksheet
Dim Unique As New Collection
Application.ScreenUpdating = False

Range("A3:K9900").ClearContents
Set sh = Worksheets("горизонтальная")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
lcol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
On Error Resume Next
For f = 6 To lcol
    If Not IsEmpty(sh.Cells(1, f)) Then Unique.Add sh.Cells(1, f).Value, CStr(sh.Cells(1, f))
Next f
   d = Unique.Count - 2
lr2 = 3
For i = 4 To lr
    n = 5
    With Worksheets("Лист1")
    If sh.Cells(1, n) = "Предоплата" Then
    n = n + 1
    End If
    For x = 1 To 3
        .Cells(lr2, 1) = sh.Cells(i, 1)
        .Cells(lr2, 2) = sh.Cells(i, 2)
        .Cells(lr2, 3) = sh.Cells(i, 3)
        .Cells(lr2, 4) = sh.Cells(i, 4)
        .Cells(lr2, 5) = sh.Cells(2, n)
        .Cells(lr2, 6) = sh.Cells(i, n)
        .Cells(lr2, 7) = sh.Cells(i, (lcol - 7) / d + 5)
        .Cells(lr2, 8) = sh.Cells(i, (lcol - 7) / d + 5 + x)
        .Cells(lr2, 9) = sh.Cells(i, (lcol - 7) / d + 5 + x + d)
        .Cells(lr2, 10) = sh.Cells(i, lcol - 1)
        .Cells(lr2, 11) = sh.Cells(i, lcol)
    lr2 = lr2 + 1
    n = n + 1
    Next x
    n = n + (lcol - 7) / d
    End With
Next i
Application.ScreenUpdating = True
End Sub