Sub Macro1()
    Dim LastRow As Long, i As Long
    With Sheets("Исходник")
        For j = 5 To 38 Step 3
            i = i + 1
            LastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(LastRow, 2).Resize(31).Value = i
            Cells(LastRow, 1).Resize(31).Value = .Range("A7:A37").Value
            Cells(LastRow, 3).Resize(31, 3).Value = .Cells(7, j).Resize(31, 3).Value
        Next
    End With
End Sub