Заполнить прямоугольную область

[toldo]

вообщем есть задание и есть программа которая работает, но код преподу не нравится я уже голову сломал, но сделать по другому не могу.

вот задание
1. Написать макрос, который выводил бы на листе рабочей книги Excel таблицу первых n простых чисел. Таблица должна содержать m столбцов. Значения n, m и координаты верхнего левого угла таблицы ввести с клавиатуры, используя функцию «InputBox». Для запуска мак-роса на листе расположить кнопку.

Dim bo As Boolean
Function second(p)
Dim b As Integer
b = 2
bo = True
While b < p
If p Mod b = 0 Then
bo = False
End If
b = b + 1
Wend
End Function
Sub Simple()
Dim k As Integer, m As Integer, n As Integer, i As Integer, j As Integer, p As Integer, x As Integer, y As Integer
m = InputBox("Input m ")
n = InputBox("Input n ")
x = InputBox("Input x ")
y = InputBox("Input y ")
k = 0
p = 2
j = y
i = x
While k < n
second (p)
If bo = True Then
Cells(i, j) = p
k = k + 1
If j = m + x - 1 Then
i = i + 1
j = y
Else
j = j + 1
End If
End If

p = p + 1
Wend

End Sub



2. Заполнить прямоугольную область на листе рабочей книги Excel случайными числами, равномерно распределенными в диапазоне [A,B]. В построенной таблице числа из первой половины интервала вывести синим цветом на желтом фоне, числа - из второй половины интервала - желтым цветом на синем фоне. Координаты начала таблицы и границы диапазона вводятся пользователем. Для запуска макроса на листе рас-положить кнопку.

вот код

im var As Boolean, randm As Integer, h As Integer, k As Integer, bool As Boolean
Function rand(a, b, x, y, kol)
var = False

While var = False
h = 0
k = 0
bool = False
randm = Int((b - a + 1) * Rnd + a)

For m = x To kol + x - 1
For n = y To (Abs(b - a + 1) / kol) + y - 1
If randm = Cells(m, n) Then bool = True
Next n
Next m

If bool = False Then rand = randm: var = True
Wend
End Function
Sub Randam()
Dim a As Integer, b As Integer, kol As Integer, j As Integer, d As Integer, x As Integer, y As Integer, temp As Integer

a = InputBox("Input a: ")
b = InputBox("Input b: ")
x = InputBox("Input x: ")
y = InputBox("Input y: ")

kol = 1
var = False

For i = 2 To Abs(b - a + 1) - 1
If Abs(b - a + 1) Mod i = 0 Then
kol = i
End If
Next i

If kol = 1 Then MsgBox ("Невозможно вывести прямоугольную область"): End

For i = x To kol + x - 1
For j = y To (Abs(b - a + 1) / kol) + y - 1
temp = rand(a, b, x, y, kol)
Cells(i, j) = temp

If temp < a + Abs(b - a + 1) / 2 Then
Cells(i, j).Interior.Color = ColorConstants.vbBlue
Cells(i, j).Font.Color = ColorConstants.vbYellow
Else
Cells(i, j).Interior.Color = ColorConstants.vbYellow
Cells(i, j).Font.Color = ColorConstants.vbBlue
End If
Next j
Next i
End Sub

3. После листа «Лист 1» вставить в книгу рабочий лист «Шрифты». На нем, для каждого из установленных в системе шрифтов вывести: в столбце А - Порядковый номер шрифта, в столбце В - Низвание шриф-та, в столбце С - фразу "Факультет ПИ" данным шрифтом 12 пт, в столбце D - фразу "Кафедра САиОИ" данным шрифтом 12 пт. Для столбцов А-D установить автоматический выбор ширины столбца. (Использовать коллекции FontNames, LandscapeFontNames, PortraitFontNames объекта Word.Application).
примечание. Не забудбте подключить через меню Сервис Ссылки библиотеку Microsoft Word Object Library и предвари
тельно запустить MS Word
Sub fonts()
Dim obj As Font, i As Integer
i = 1
If Sheets(2).Name = "Шрифты" Then
Sheets("Шрифты").Activate
Else
Sheets.Add Type:=xlWorksheet, Count:=1, before:=Sheets("Лист2")
Sheets(2).Activate
Sheets(2).Name = "Шрифты"
End If

For Each Font In FontNames
Cells(i, 1) = i
With Cells(i, 3)
.Value = "Факультет ПИ"
.Font.Name = FontNames(i)
.Font.Size = 12
End With

With Cells(i, 4)
.Value = "Кафедра САОИ"
.Font.Name = FontNames(i)
.Font.Size = 12
End With

Cells(i, 2) = FontNames(i)
i = i + 1
Next
Columns("A:D").AutoFit
End Sub

[toldo]

4.Простые числа из таблицы, построенной в задании 1, «разнесите» по различным листам рабочей книги. Для этого напишите макрос, ко-торый бы согласно введенному значению n, создавал листы с именами "1-99", "100-199", "200-299" и т.д. На лист "А-В" должны переноситься числа значения которых не меньше А и не больше В. Для обхода таб-лицы используйте цикл For each.

Sub raznos()
Dim a As Integer, b As Integer, sw As Boolean, n As Integer, i As Integer, j As Integer, temp As Boolean, k As Integer, t As Integer
sw = False
a = 0
b = 99
i = 1
j = 1
k = 1
temp = False
For Each numb In Worksheets("Ïðîñòûå ÷èñëà").Range("A1 :IV65536").Cells

If numb > b - 100 Then
sw = False
i = 1
j = 1
End If

If sw = False Then
n = Sheets.Count
Sheets.Add Type:=xlWorksheet, Count:=1, After:=Sheets(n)
Sheets(n + 1).Name = a & "-" & b
a = a + 100
b = b + 100
sw = True
End If

If numb < b - 100 And numb > a - 100 Then
Sheets(n + 1).Cells(j, 1) = numb
j = j + 1
temp = True
End If

If temp = True And numb = "" Then
k = k + 1
End If

If numb <> "" Then
k = 0
End If

If k > 254 Then
End
End If
Next
End Sub

5.Напишите функцию, которая бы для диапазона, передаваемого ей в качестве параметра, и признака типа результата, находила бы количе-ство четных чисел, содержащихся в диапазоне, если значение типа ре-зультата = 1, нечетных чисел, если значение типа результата = 2, чисел, состоящих только из нечетных цифр, если значение типа результата = 3 (число можно преобразовать в строку при помощи функции CStr)

Function fn(l, r, k)
Dim a As Range, b As Range, res As Integer, str As String
res = 0
Set a = Лист3.Range(l, r)
For Each b In a.Cells
If k = 1 And b.Value Mod 2 = 0 Then res = res + 1

If k = 2 And b.Value Mod 2 <> 0 Then res = res + 1

If k = 3 And bI(b.Value) = True Then res = res + 1
Next
fn = res
End Function

Function bI(n As Integer)
Dim tmp As Integer, bool As Boolean
bool = True
Do
tmp = n Mod 10
If tmp Mod 2 = 0 And tmp <> 0 Then
bI = False
bool = False
End If
n = (n - tmp) / 10
Loop While n > 0
If bool = False Then bI = False Else bI = True
End Function

Sub chisla()
Dim rng As Range, k As Integer, l As String, r As String
l = InputBox("Input range l:", , "D7")
r = InputBox("Input range r:", , "F12")
k = InputBox("Input k:")
Лист3.Cells(1, 1) = fn(l, r, k)
End Sub


6.Напишите макрос, который заполнял бы выделенный на рабочем листе диапазон случайным образом числами, текстовыми данными, формулами, датами. И позволял бы:
-Раскрасить диапазон соответственно содержимому ячеек. Например, ячейку с числами - залить красным фоном, с тек-стами - синим и т.д. (Для определения типа содержимого ячейки использовать функции объекта Application для полу-чения сведений о типе переменной - IsText, IsFormula, IsNumeric, IsData и т.п. ).
-Непосредственно под выделенным диапазоном вывести ин-формацию о количестве ячеек, содержащих числа, тексты, формулы, даты.

Function str()
Dim n As Integer, s As String

n = 10 * Rnd + 2

For i = 1 To n

s = s + Chr(222 * Rnd + 33)
Next i

str = s
End Function

Sub six()

Dim obj As Range, sel As Integer, koln As Integer, kold As Integer, kols As Integer, n As Integer

n = 0
koln = 0
kold = 0
kols = 0

Worksheets("Форматы").Activate

For Each obj In Selection

sel = 2 * Rnd + 1

If sel = 1 Then
obj.NumberFormat = "@"
obj = str()
kols = kols + 1
End If

If sel = 2 Then
obj.NumberFormat = "0.00"
obj = 9 * Rnd
koln = koln + 1
End If
If sel = 3 Then
obj.NumberFormat = "d/m/yy;@"
obj = 9 * Rnd
kold = kold + 1
End If
n = n + 1
Next

For Each obj In Selection

num = num + 1
If WorksheetFunction.IsText(obj) Then
obj.Interior.Color = ColorConstants.vbRed
End If

If WorksheetFunction.IsNumber(obj) Then
obj.Interior.Color = ColorConstants.vbYellow
End If

If IsDate(obj) Then
obj.Interior.Color = ColorConstants.vbBlue
End If

If num = n - 1 Then
obj.Offset(1, 0) = "Ñòðîêè"
obj.Offset(1, 0).NumberFormat = "@"
obj.Offset(2, 0) = "×èñëà"
obj.Offset(2, 0).NumberFormat = "@"
obj.Offset(3, 0) = "Äàòû"
obj.Offset(3, 0).NumberFormat = "@"
End If

If num = n Then
obj.Offset(1, 0) = koln
obj.Offset(1, 0).NumberFormat = "0"
obj.Offset(2, 0) = kold
obj.Offset(2, 0).NumberFormat = "0"
obj.Offset(3, 0) = kols
obj.Offset(3, 0).NumberFormat = "0"
End If

Next


End Sub

[EducatedFool]

но код преподу не нравится я уже голову сломал, но сделать по другому не могу

что именно не нравится?
мне очень даже нравится

а переделывать кучу кода в надежде, что он понравится преподу - занятие неблагодарное.

Знаете, почему преподу не нравится код?
Скорее всего потому, что этот код не ваш, и это сразу видно.

Напишите код самостоятельно - и препод будет доволен.

[toldo]

он не мой частично, примерно на половину.
А препод говорит что надо сделать по другому а как я не знаю, на второй части я и погорел

For i = x To kol + x - 1
For j = y To (Abs(b - a + 1) / kol) + y - 1
temp = rand(a, b, x, y, kol)
Cells(i, j) = temp

что эти строки обозначают??

[IgorGO]

это значит:
начиная со строки х, в kol строк, ячейки с у по (Abs(b - a + 1) / kol) + y - 1 будут заполнены случайными числами, которые вернет функция rand

[valerij]

Сообщение от toldo

он не мой частично, примерно на половину.
А препод говорит что надо сделать по другому а как я не знаю, на второй части я и погорел

For i = x To kol + x - 1
For j = y To (Abs(b - a + 1) / kol) + y - 1
    temp = rand(a, b, x, y, kol)
    Cells(i, j) = temp
next j
next i

что эти строки обозначают??

Два вложенных цикла, сначала берется первое значение i(= х) и выполняется цикл j, затем второе значение i и опять второй цикл....
temp =rand - переменная = случайному числу, значения i и j меняют координаты ячейки Cells(i, j)

[toldo]

спс)


помогите с остальным пожалуйста