mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

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

Функция 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

ВложениеРазмерЗагрузкиПоследняя загрузка
RandomRowsFromArray.xls47 КБ1091 неделя 1 день назад

Комментарии

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

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

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 / | _| \ V / | (_| | / \ | |_| |
\_/ |_| \_/ \__, | /_/\_\ \____|
|___/
Введите код, изображенный в стиле ASCII-арт.

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

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