Sub разбить_по_квартирам()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim i&, j&, lr&, r&, k&, rr&
    Dim shData As Worksheet, shRes As Worksheet, rng
    Set shData = ThisWorkbook.Sheets("Лист2")
    Set shRes = ThisWorkbook.Sheets("Лист1")
    shRes.[a4].Resize(shRes.Rows.Count - 3, 28).ClearContents
    With shData
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
        rng = .Range("a4:ab" & lr).Value
        Dim curR&, curC&
        curR = ActiveCell.Row: curC = ActiveCell.Column
        rr = Rows.Count
        Dim rngRes()
        r = 0
        For i = 1 To lr - 3
            For j = 1 To rng(i, 12)
                ReDim Preserve rngRes(0 To 27, 0 To r)
                For k = 1 To 28
                    rngRes(k - 1, r) = rng(i, k)
                Next k
                rngRes(11, r) = j
                r = r + 1
            Next j
        Next i
        With shRes
            .[a4].Resize(r, 28).Value = Application.Transpose(rngRes)
            shData.Range("a4:ab4").Copy
            .Range("a4:ab" & r + 3).PasteSpecial Paste:=xlPasteFormats
        End With
    End With
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
End Sub