Выборка случайных строк из двумерного массива

Функция RandomRowsFromArray предназначена для выборки из двумерного массива случайных строк.

К примеру, исходный массив (таблица) имеет размер 1000*20 (1000 строк, и 20 столбцов)
Нам требуется выбрать из этой таблицы, случайным образом, 50 строк
(получив, таким образом, таблицу размерами 50*20)
Кроме того, необходимо, чтобы при каждом новом запуске макроса,
в выборку попадали новые строки
.

В прикреплённом к статье файле вы найдете пример такого макроса:

Sub ПримерИспользования_RandomRowsFromArray()
    ' считываем массив с листа
    arr = [a1:e20].Value
    ' считываем количество строк в выборке
    Количество = Val([NewCount])
 
    ' выбираем строки из массива случайным образом (получаем новый массив newarr)
    newarr = RandomRowsFromArray(arr, Количество)
 
    ' заносим результат на лист (справа от исходных данных)
    Range("g1").Resize(UBound(newarr, 1), UBound(newarr, 2)).Value = newarr
End Sub

Код функции RandomRowsFromArray:

Function RandomRowsFromArray(ByRef arr, ByVal count&)
    ' Функция выбирает из двумерного массива arr в случайном порядке count& строк.
    ' Возвращает массив (равный исходному по ширине), содержащий выбранные строки
    ' Подразумевается нумерация строк массива с единицы (Option Base 1)

    On Error Resume Next
    If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical, _
       "Ошибка в функции RandomRowsFromArray": End
    rc& = UBound(arr, 1)
    ' если строк в массиве меньше, чем требуется выбрать, - возвращаем исходный массив
    If rc <= count& Then RandomRowsFromArray = arr: Exit Function
    If count& <= 0 Then MsgBox "Количество выбираемых строк должно быть >0", vbCritical, _
       "Ошибка в функции RandomRowsFromArray": End
 
    Dim coll As New Collection, i As Long
    While coll.count < count&    ' генерируем несовпадающие случайные числа в количестве count&
        Randomize
        n& = Fix(Rnd() * rc + 1): coll.Add n, CStr(n)
        iter& = iter& + 1: If iter& > count& * 100# Then MsgBox "Зацикливание функции", vbCritical, _
                              "Ошибка в функции RandomRowsFromArray": End
    Wend
 
    ReDim newarr(1 To count&, LBound(arr, 2) To UBound(arr, 2))
    For i = 1 To coll.count
        n& = coll(i): For j = LBound(arr, 2) To UBound(arr, 2): newarr(i, j) = arr(n, j): Next j
    Next
    RandomRowsFromArray = newarr    ' возвращаем сформированный массив
End Function

Вложения:

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Спасибо за ответ, Игорь!
Да там в коде нет никаких изменений, только добавил Do Loop Until

Немного погуглив, я пришел к выводу, что моя проблема в самой Randomize, точнее в том, что она генерирует числа, зависящие от предыдущего результата. Оттого и зацикливание макроса до удовлетворения условию, заданному Until, приводит к одинаковым результатам.
Тогда вопрос - возможно ли усложнить (или заменить) функцию Randomize на что-то более непредсказуемое?
можно ли пристроить как-то класс RandomNumberGenerator? (Оставляя при этом смысл вашего макроса - выборка случайных строк из массива)

По вашему описанию, не видя кода, сложно что-либо понять
Тем более, ваш вопрос не относится к теме статьи
Обратитесь на форумы по Excel - там помогут быстро и бесплатно.

Приветствую, Игорь (и посетители сего полезного ресурса).
Спасибо вам, что делитесь своей работой!

Я злостный гуманитарий, поэтому возможно (скорее всего) я сделал что-то не правильно.
Имеется массив, к примеру, в 300 уникальных строк ([a1:f300]), в каждой ячейке числа в диапазоне от 1 до 45. Там же на листе формула (СЧЁТЕСЛИ), считающая значения во вновь сформированном массиве (к примеру в 25 строк).
ЗАДАЧА: зациклить макрос генератор, пока СЧЁТЕСЛИ не достигнет определенного значения.
КАК Я ЭТО РЕШИЛ (на самом деле, знакомый индус подсказал): зацикливание Do (до считывания массива) Loop Until сссылка на ячейку со СЧЁТЕСЛИ и нужное значение.
ПРОБЛЕМА: цикл как бы работает, т.е. цикл останавливается, когда в Untill получает нужное значение, но при повторном запуске, некоторого времени работы цикла, такая конструкция выдает в newarr построчно одинаковые массивы. то есть поначалу рэндом как бы есть, а потом его кагбы нет. Макрос вроде бы работает, но выдает одинаковый результат.
Надеюсь на помощь. Намастэ!

n& = coll(i): For j = LBound(arr, 2) To UBound(arr, 2): newarr(i, j) = arr(n, j): Next j

Добрый день появился вопрос, ": " двоеточие и пробел это вместо переноса строки?

Хорошо, я понимаю.
Благодарю за быстрый ответ! : )

А если на заказ, то сколько это будет стоить?

Rokinso, увы, помочь не смогу.
Тут надо совсем другой макрос делать, и ваш файл смотреть, чтобы понять, что и как.
Ну и должны быть где-то настройки, - вероятность выпадения того или иного предмета.
Сделать можно, - но только под заказ (работы много)
Если хотите бесплатно, - обращайтесь на форумы по Excel.

Хочу сделать, чтобы приоритет можно было указывать в отдельном столбце - для каждой строки своё значение.
Чтобы Юзер (Ведущий) мог сам изменять приоритет выпадения каждого предмета по ходу игры.

Пожалуйста, подскажите, как увеличить вероятность попадания в выборку определённой строки?

Я делаю генератор предметов, которые игрок может найти в тайниках.
Мне нужно, чтобы спички он мог найти в 30% случаев обыска, а вот артефакты - лишь в 1% случаев.

Дублирование строк для увеличения вероятности выпадения - очень неудобно, когда уникальных строк более 300-та. ))

-
P.S. Уважаемый Администратор, ОГРОМНОЕ Вам СПАСИБО за то, что делитесь с нами плодами своего бесценного труда и, к тому же, снабжаете свои коды подробными описаниями, чтобы даже такой стопроцентный гуманитарий как я смог быстро вникнуть в экселевские премудрости и сосредоточиться, главным образом, на творческом процессе разработки игры.

Низкий Вам поклон. : )

Доброго, а как сделать так чтобы он не копировал данные ячейки а вырезал из исходной?

Подскажи плиз как догда можно зделать чтобы интервал поиска ячеек arr = worksheets("Название листа").[a1:e20].Value, можно было вводит на листе excel, тот который будет унас размешен массив.

Славься о мудрейший, офигенно полезный макрос!

чтобы он считывал данные не стекушего листа а стого который нам нужен

Вместо

' считываем массив с активного листа
   arr = [a1:e20].Value

напишите

' считываем массив с заданного листа
   arr = worksheets("Название листа").[a1:e20].Value

После считывания массива, удалите из него пустые строки при помощи этой функции:
http://excelvba.ru/code/DeleteBlankRows

как данный макрос превратить так чтобы он считывал данные не стекушего листа а стого который нам нужен при этом чтобы учитывал пустые ячейки и не считывал их

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
                               _   _      _    
_ _ __ __ __ __ ____ | | | | / \
| | | | \ \/ / \ \ / / |_ / | | | | / _ \
| |_| | > < \ V / / / | |_| | / ___ \
\__, | /_/\_\ \_/ /___| \___/ /_/ \_\
|___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.