Elizavetta, могу предложить код с оговорками:
1.Могу ошибаться, генераторы случайных чисел подчиняются-таки определенным законам. Вероятно, с небольшими наборами данных это не будет прослеживаться, но в рамках конкретного алгоритма какое получается распределение - вопрос открытый.
2.Программа дает близкое соотношение по процентам, но не точное. Кроме того, для каждого вопроса после окончания работы скрипта возможно наличие одной незаполненной ячейки. Добивать алгоритм смысла не вижу (откровенно говоря - лень), раз вопрос по статистике - вероятно в любом случае будет нужно что-нибудь подправлять руками. Пустые ячейки легко отследить фильтром по таблице1 и устранить.
3. Таблица1 должна быть пустой - заполнение выполняется только в незаполненные ячейки.
Алгоритм работы следующий:
1. Вашу таблицу с ответами необходимо отформатировать как таблицу (сочетание клавиш ctrl+L). Называться она должна "Таблица1" (Название можно привести в соответствие с помощью диспетчера имен вкладки "Формулы").
Скрин Таблицы1 и диспетчера имен
2. Необходимо создать в произвольном месте того же листа еще одну таблицу с картой ответов. Называться она должна "Таблица2". Названия заголовков непринципиальны, но содержание должно четко соответствовать Таблице1 по названию категорий и вопросов, т.е. если в Таблице2 фигурирует "Категория 3", значит она должна быть и в Таблице1, или если названия вопросов Х1 написаны как английское "икс", то в другой таблице не должно быть русское "хэ". В таблице указываете для каждой категории название вопроса, один из вариантов ответа и процент ответа в десятых долях от единицы. Можно заполнить не все категории - отработают только заполненные категории.
Скрин Таблицы 2 (карты ответов)
Собственно код
Код:
Public Sub Sociology()
Dim i As Long, j As Long, n As Long, Nkat As Long, m As Long
Dim Kat As String, Kat_old As String
Dim quest As String
Dim answ As String
Dim Perc As Double
Dim cell As Range
Randomize
On Error Resume Next
For i = 1 To Range("Таблица2").Rows.Count
Kat = Range("Таблица2").Cells(i, 1).Value
quest = Range("Таблица2").Cells(i, 2).Value
answ = Range("Таблица2").Cells(i, 3).Value
Perc = Range("Таблица2").Cells(i, 4).Value
ActiveSheet.ListObjects("Таблица1").Range.AutoFilter Field:=1, Criteria1:=Kat
Range("Таблица1[" & quest & "]").SpecialCells(xlCellTypeBlanks).Select
Selection.SpecialCells(xlCellTypeVisible).Select
'Debug.Print "выделено " & Selection.Count
If Kat <> Kat_old Then
Nkat = Selection.Count
Kat_old = Kat
End If
m = 0
Do
n = Selection.Count
n = Round(n * Rnd())
If n = 0 Then n = 1
j = 0
For Each cell In Selection
j = j + 1
If j = n Then
cell.Value = answ
m = m + 1
Exit For
End If
Next cell
Range("Таблица1[" & quest & "]").SpecialCells(xlCellTypeBlanks).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Loop Until m >= Nkat * Perc Or Err.Number <> 0
'Debug.Print "err=" & Err.Number & ", m=" & m & ",Nkat*perc=" & Nkat * Perc & ",j=" & j
Err.Clear
ActiveSheet.ListObjects("Таблица1").Range.AutoFilter Field:=1
Next i
Range("Таблица2").Select
End Sub
