Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Случайный выбор слова и случайные варианты ответа - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Случайный выбор слова и случайные варианты ответа (Макросы/Sub)
Случайный выбор слова и случайные варианты ответа
Sesya Дата: Суббота, 16.01.2016, 19:40 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый вечер!Помогите, пожалуйста, из столбца В случайным образом выбирается слово на Листе 1 и к нему подбирается 5 вариантов ответа, среди которых один верный. Неверные варианты ответа должны быть того же критерия, что и верный ответ. Варианты ответов должны выбираться и располагаться каждый раз в произвольном порядке.
К сообщению приложен файл: 8522eb6c-63b2-4.xlsx(9Kb)
 
Ответить
СообщениеДобрый вечер!Помогите, пожалуйста, из столбца В случайным образом выбирается слово на Листе 1 и к нему подбирается 5 вариантов ответа, среди которых один верный. Неверные варианты ответа должны быть того же критерия, что и верный ответ. Варианты ответов должны выбираться и располагаться каждый раз в произвольном порядке.

Автор - Sesya
Дата добавления - 16.01.2016 в 19:40
Udik Дата: Суббота, 16.01.2016, 20:39 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1586
Репутация: 191 ±
Замечаний: 0% ±

Excel 2016 х 64
Критерия только 3 и они именно цифровые?


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
СообщениеКритерия только 3 и они именно цифровые?

Автор - Udik
Дата добавления - 16.01.2016 в 20:39
Sesya Дата: Суббота, 16.01.2016, 22:07 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Udik, критериев может быть больше, но они все будут цифровые
 
Ответить
СообщениеUdik, критериев может быть больше, но они все будут цифровые

Автор - Sesya
Дата добавления - 16.01.2016 в 22:07
Manyasha Дата: Суббота, 16.01.2016, 23:06 | Сообщение № 4
Группа: Модераторы
Ранг: Старожил
Сообщений: 1957
Репутация: 815 ±
Замечаний: 0% ±

Excel 2010, 2016
Sesya, Вы написали:
из столбца В случайным образом выбирается слово

а в файле у вас наоборот (слово выбирается из С, а из В - 5 вариантов).
Сделала, как в файле, если нужно наоборот, в 2-х строчках столбцы поправите:
[vba]
Код
Sub primer()
    Set sh1 = ThisWorkbook.Sheets(1)
    With sh1
        lr = .Cells(.Rows.Count, 2).End(xlUp).Row
        Randomize
        indWord = Int((lr - 1) * Rnd + 2)
        'выбираем слово для перевода из столбца С
        Sheets(2).Range("d4") = .Cells(indWord, "c")
        cat = .Cells(indWord, 4)
        With CreateObject("Scripting.Dictionary")
            Do
                r = Int((lr - 1) * Rnd + 2)
                If sh1.Cells(r, 4) = cat Then
                    .Item(r) = .Item(r) + 1
                End If
            Loop While .Count < 5
            Arr = .keys
            For i = 0 To .Count - 1
                'варианты перевода из столбца B
                Cells(6 + i, 4) = sh1.Cells(Arr(i), "b")
            Next
        End With
    End With
End Sub
[/vba]
К сообщению приложен файл: 8522eb6c-63b2-4.xlsm(19Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеSesya, Вы написали:
из столбца В случайным образом выбирается слово

а в файле у вас наоборот (слово выбирается из С, а из В - 5 вариантов).
Сделала, как в файле, если нужно наоборот, в 2-х строчках столбцы поправите:
[vba]
Код
Sub primer()
    Set sh1 = ThisWorkbook.Sheets(1)
    With sh1
        lr = .Cells(.Rows.Count, 2).End(xlUp).Row
        Randomize
        indWord = Int((lr - 1) * Rnd + 2)
        'выбираем слово для перевода из столбца С
        Sheets(2).Range("d4") = .Cells(indWord, "c")
        cat = .Cells(indWord, 4)
        With CreateObject("Scripting.Dictionary")
            Do
                r = Int((lr - 1) * Rnd + 2)
                If sh1.Cells(r, 4) = cat Then
                    .Item(r) = .Item(r) + 1
                End If
            Loop While .Count < 5
            Arr = .keys
            For i = 0 To .Count - 1
                'варианты перевода из столбца B
                Cells(6 + i, 4) = sh1.Cells(Arr(i), "b")
            Next
        End With
    End With
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 16.01.2016 в 23:06
Sesya Дата: Воскресенье, 17.01.2016, 10:51 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, огромное спасибо hands hands hands :) :D :D
 
Ответить
СообщениеManyasha, огромное спасибо hands hands hands :) :D :D

Автор - Sesya
Дата добавления - 17.01.2016 в 10:51
Udik Дата: Воскресенье, 17.01.2016, 15:50 | Сообщение № 6
Группа: Друзья
Ранг: Старожил
Сообщений: 1586
Репутация: 191 ±
Замечаний: 0% ±

Excel 2016 х 64
тоже по примеру файла
[vba]
Код

Dim arrAll(), arrI()
Dim rng1 As Range
Const LBNAME As String = "basa"
Const LTNAME As String = "Лист1"

Public Sub setData()
Dim numRow As Long
Dim i As Long, j As Long, k As Long
Dim maxN As Integer

With Worksheets(LBNAME)
.Activate
numRow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng1 = Worksheets(LBNAME).Range("A1", Cells(numRow, 4))
End With
For i = 2 To rng1.Rows.Count
    If maxN < rng1.Cells(i, 4) Then maxN = rng1.Cells(i, 4)
Next i
ReDim arrAll(1 To maxN)
For j = 1 To maxN
    k = 0
    ReDim arrI(1 To numRow)
    For i = 2 To numRow
        If rng1.Cells(i, 4) = j Then
            k = k + 1
            arrI(k) = i
        End If
    Next i
    ReDim Preserve arrI(1 To k)
    arrAll(j) = arrI
Next j
End Sub

Public Sub chooseWrd()
Dim arrNum As Integer
Dim i As Integer, j As Integer
Dim k As Long, l As Long, buff As Long

If (Not arrAll) = -1 Then 'существует ли массив
    Call setData
End If
arrNum = UBound(arrAll)
Randomize
i = Int((arrNum * Rnd) + 1)
l = UBound(arrAll(i))
For j = 1 To l
    k = Int((l * Rnd) + 1)
    buff = arrAll(i)(j)
    arrAll(i)(j) = arrAll(i)(k)
    arrAll(i)(k) = buff
Next j
With Worksheets(LTNAME)
.Activate
For j = 1 To 5
  .Cells(5 + j, 4).Value = rng1.Cells(arrAll(i)(j), 2)
Next j
j = Int((5 * Rnd) + 1)
.Cells(4, 4).Value = rng1.Cells(arrAll(i)(j), 3)
End With
End Sub

[/vba]
К сообщению приложен файл: t1.xlsm(27Kb)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
Сообщениетоже по примеру файла
[vba]
Код

Dim arrAll(), arrI()
Dim rng1 As Range
Const LBNAME As String = "basa"
Const LTNAME As String = "Лист1"

Public Sub setData()
Dim numRow As Long
Dim i As Long, j As Long, k As Long
Dim maxN As Integer

With Worksheets(LBNAME)
.Activate
numRow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng1 = Worksheets(LBNAME).Range("A1", Cells(numRow, 4))
End With
For i = 2 To rng1.Rows.Count
    If maxN < rng1.Cells(i, 4) Then maxN = rng1.Cells(i, 4)
Next i
ReDim arrAll(1 To maxN)
For j = 1 To maxN
    k = 0
    ReDim arrI(1 To numRow)
    For i = 2 To numRow
        If rng1.Cells(i, 4) = j Then
            k = k + 1
            arrI(k) = i
        End If
    Next i
    ReDim Preserve arrI(1 To k)
    arrAll(j) = arrI
Next j
End Sub

Public Sub chooseWrd()
Dim arrNum As Integer
Dim i As Integer, j As Integer
Dim k As Long, l As Long, buff As Long

If (Not arrAll) = -1 Then 'существует ли массив
    Call setData
End If
arrNum = UBound(arrAll)
Randomize
i = Int((arrNum * Rnd) + 1)
l = UBound(arrAll(i))
For j = 1 To l
    k = Int((l * Rnd) + 1)
    buff = arrAll(i)(j)
    arrAll(i)(j) = arrAll(i)(k)
    arrAll(i)(k) = buff
Next j
With Worksheets(LTNAME)
.Activate
For j = 1 To 5
  .Cells(5 + j, 4).Value = rng1.Cells(arrAll(i)(j), 2)
Next j
j = Int((5 * Rnd) + 1)
.Cells(4, 4).Value = rng1.Cells(arrAll(i)(j), 3)
End With
End Sub

[/vba]

Автор - Udik
Дата добавления - 17.01.2016 в 15:50
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Случайный выбор слова и случайные варианты ответа (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!