код это вот это?
Sub perebor()
Dim fam(), famDic As Object, procDic As Object, i&, ii&
Dim el, cnt&, tmp As Object, x&, z&
Set famDic = CreateObject("Scripting.Dictionary")
famDic.CompareMode = 1
Set procDic = CreateObject("Scripting.Dictionary")
procDic.CompareMode = 1
'1 (динамически, т.е. диапазон может быть любой вправо/вниз, в примере можно брать весь UsedRange).
fam = Sheets(2).UsedRange.Value
'1. заносим в словарь фамилии, каждой в Item процент
For ii = 1 To UBound(fam, 2)
For i = 2 To UBound(fam, 1) - 1
If Len(fam(i, ii)) Then famDic.Item(fam(i, ii)) = fam(UBound(fam), ii)
Next i, ii
'2. в другой словарь тоже теже проценты, но с пустыми коллекциями в Item.
For i = 1 To UBound(fam, 2)
procDic.Add fam(UBound(fam), i), New Collection
Next i
'3. перебор списка фамилий, каждую проверяем по первому словарю, определяем процент и в его коллекцию (во втором словаре) добавляем фамилию.
fam = Sheets(1).[a1].CurrentRegion.Value 'массив всего обрабатываемых фамилий, его же будем юзать как массив-результат
'3. перебор списка фамилий
For i = 2 To UBound(fam)
'3. каждую проверяем по первому словарю, определяем процент и в его коллекцию (во втором словаре) добавляем фамилию.
If famDic.exists(fam(i, 1)) Then procDic.Item(famDic.Item(fam(i, 1))).Add fam(i, 1)
Next
'4. цикл по второму словарю - по проценту и количеству собранных элементов высчитываем количество нужных фамилий, выбираем их из коллекции (можно взять подряд сверху/снизу, можно генерить случайные числа в пределе от 1 до количества элементов, выбирать (с удалением) из коллекции по этому числу, генерить снова).
ii = 1 'ФИО не трогаем
For Each el In procDic.keys 'el=процент
cnt = procDic.Item(el).Count 'количество отобранных человек
x = Round((el * cnt), 0) 'человек нужно выбрать по группе (тут внимание - процент наличествующих!)
Set tmp = procDic.Item(el) 'так меньше ломает голову, но позже можно упразднить :)
'коллекция отобранных
For i = 1 To x
ii = ii + 1
z = Random(1, tmp.Count)
fam(ii, 1) = tmp(z)
tmp.Remove z
Next
Next
Sheets(3).[C1].Resize(ii, 1) = fam
End Sub
Public Function Random(ByVal Lowerbound As Long, ByVal Upperbound As Long) As Long
Randomize
Random = Int((Upperbound - Lowerbound) * Rnd + Lowerbound)
End Function
