Функция 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напишите
После считывания массива, удалите из него пустые строки при помощи этой функции:
http://excelvba.ru/code/DeleteBlankRows
как данный макрос превратить так чтобы он считывал данные не стекушего листа а стого который нам нужен при этом чтобы учитывал пустые ячейки и не считывал их
Отправить комментарий