Имя пользователя:
Пароль:
 

Показать сообщение отдельно

Динохромный


Contributor


Сообщения: 712
Благодарности: 322

Профиль | Отправить PM | Цитировать


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
Это сообщение посчитали полезным следующие участники:

Отправлено: 12:21, 03-12-2015 | #13