Показать комбинации в Excel

Question

У меня есть эта проблема: Если у кого-то есть пять рабочих мест и есть 50 сотрудников, занятых неполный рабочий день (1 - 50). Каковы все возможные комбинации, когда каждый сотрудник из 50 человек может одновременно испытать 5 рабочих мест / ролей.

Мне нужно показать все возможности в электронной таблице.

I Я сделал этот код VBA ниже и рассчитал 4176 возможностей, но я думаю, что результат должен быть намного больше, потому что комбинация (50,5) = 2118760.

Это правильно?

Sub Possibilidades()

'Criar as variaveis referentes aos postos de trabalho e aos empregados
Dim jp, emp, totalemp, contjp, contemp, aux, auxemp As Integer
totalemp = Range("B1").Value
jp = Range("B2").Value
contemp = 1
'Posiciona célula para imprimir possibilidades
Range("B5").Activate

'Laço para criar blocos de 5 empregados
For emp = 1 To totalemp - 4

    'Laço para atribuir posto de trabalho a cada funcionário
    For contjp = 1 To jp
        ActiveCell.FormulaR1C1 = "=""Emp""&" & contemp
        contemp = contemp + 1
        ActiveCell.Offset(0, 1).Activate
    Next contjp
    contemp = contemp - 4
ActiveCell.Offset(1, -jp).Activate
Next emp

'Separação de blocos de comando
'ActiveCell.Offset(1, 0).Activate

'Trava em 1 funcionário e em seguida mover blocos de 4 funcionarios
For emp = 1 To totalemp - 5
    contemp = emp + 2

    'Criar bloco de 4 funcionarios pulando 1 casa para evitar repeticao, ou seja, emp3 em diante
    For aux = contemp To totalemp
        ActiveCell.FormulaR1C1 = "=""Emp""&" & emp
        ActiveCell.Offset(0, 1).Activate
            For contjp = 2 To jp
                ActiveCell.FormulaR1C1 = "=""Emp""&" & contemp
                contemp = contemp + 1
                ActiveCell.Offset(0, 1).Activate
                aux = contemp - 1
            Next contjp
        contemp = contemp - 3
        ActiveCell.Offset(1, -jp).Activate
    Next aux
Next emp

'Separação de blocos de comando
'ActiveCell.Offset(1, 0).Activate

'Trava em 2 funcionários e em seguida mover blocos de 3 funcionarios
For emp = 1 To totalemp - 6
    contemp = emp + 3
    auxemp = emp

    'Criar bloco de 3 funcionarios pulando 2 casa para evitar repeticao, ou seja, emp4 em diante
    For aux = contemp To totalemp
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp + 1
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp - 1
            For contjp = 3 To jp
                ActiveCell.FormulaR1C1 = "=""Emp""&" & contemp
                contemp = contemp + 1
                ActiveCell.Offset(0, 1).Activate
                aux = contemp - 1
            Next contjp
        contemp = contemp - 2
        ActiveCell.Offset(1, -jp).Activate
    Next aux
Next emp

'Separação de blocos de comando
'ActiveCell.Offset(1, 0).Activate

'Trava em 3 funcionários e em seguida mover blocos de 2 funcionarios
For emp = 1 To totalemp - 7
    contemp = emp + 4
    auxemp = emp

    'Criar bloco de 3 funcionarios pulando 2 casa para evitar repeticao, ou seja, emp5 em diante
    For aux = contemp To totalemp
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp + 1
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp + 1
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp - 2
            For contjp = 4 To jp
                ActiveCell.FormulaR1C1 = "=""Emp""&" & contemp
                contemp = contemp + 1
                ActiveCell.Offset(0, 1).Activate
                aux = contemp - 1
            Next contjp
        contemp = contemp - 1
        ActiveCell.Offset(1, -jp).Activate
    Next aux
Next emp

'Separação de blocos de comando
'ActiveCell.Offset(1, 0).Activate

'Trava em 4 funcionários e em seguida mover blocos de 1 funcionarios
For emp = 1 To totalemp - 8
    contemp = emp + 5
    auxemp = emp

    'Criar bloco de 4 funcionarios pulando 1 casa para evitar repeticao, ou seja, emp6 em diante
    For aux = contemp To totalemp
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp + 1
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp + 1
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp + 1
        ActiveCell.FormulaR1C1 = "=""Emp""&" & auxemp
        ActiveCell.Offset(0, 1).Activate
        auxemp = auxemp - 3
            For contjp = 5 To jp
                ActiveCell.FormulaR1C1 = "=""Emp""&" & contemp
                contemp = contemp + 1
                ActiveCell.Offset(0, 1).Activate
                aux = contemp - 1
            Next contjp
        ActiveCell.Offset(1, -jp).Activate
    Next aux
Next emp

'Conta as combinações
ActiveCell.Offset(-1, -1).Activate
auxemp = ActiveCell.Row - 4
Range("A5").Select
For aux = 1 To auxemp
    ActiveCell.FormulaR1C1 = "=Row()-4"
    ActiveCell.Offset(1, 0).Activate
Next aux

'Concatena as combinações
Range("G5").Select
For aux = 1 To auxemp
    ActiveCell.FormulaR1C1 = "=RC[-5]&"", ""&RC[-4]&"", ""&RC[-3]&"", ""&RC[-2]&"", ""&RC[-1]"
    ActiveCell.Offset(1, 0).Activate
Next aux

Range("G1").Select
ActiveCell.FormulaR1C1 = "= ""Done! Possibilities =  ""&" & auxemp

End Sub

Answer 1

Вы можете попробовать этот код, общая комбинация составляет 2118760. Следовательно, один столбец определенно не может вписаться во все. Вы можете добавить некоторый код для изменения столбца во время работы в l oop.

См. Прикрепленные изображения, если хотите попробовать.

Option Explicit

Sub combination()

Dim Pos, Emp As Range
Dim PV1, PV2 As Integer
Dim FV1, FV2 As String
Dim Out1 As Range
Dim i As Integer

i = 1
Set Pos = Range("A1:A5")
Set Emp = Range("B1:B50")
Set Out1 = Cells(i, 4)

For PV1 = 1 To Pos.Count
FV1 = Pos.Item(PV1).Text
For PV2 = 1 To Emp.Count
FV2 = Emp.Item(PV2).Text
Out1.value = FV1 & FV2

Cells(i, 5).value = Cells(i, 4).value
Cells(i, 6).value = Cells(i, 4).value
Cells(i, 7).value = Cells(i, 4).value
Cells(i, 8).value = Cells(i, 4).value

i = i + 1
Set Out1 = Out1.Offset(1, 0)
Next
Next

Columns.AutoFit

End Sub

Sub combination2()

Dim a, b, c, d, ee As Range
Dim aPV, bPV, cPV, dPV, ePV As Integer
Dim aFV, bFV, cFV, dFV, eFV As String
Dim Out2 As Range
Dim comm As String
Dim i, j As Integer

Application.Calculation = xlManual
Application.ScreenUpdating = False

Set a = Range("D1:D250")
Set b = Range("E1:E250")
Set c = Range("F1:F250")
Set d = Range("G1:G250")
Set ee = Range("H1:H250")
comm = ","
i = 1
j = 10

Set Out2 = Cells(i, j)

For aPV = 1 To a.Count
aFV = a.Item(aPV).Text
For bPV = 1 To b.Count
bFV = b.Item(bPV).Text
For cPV = 1 To c.Count
cFV = c.Item(cPV).Text
For dPV = 1 To d.Count
dFV = d.Item(dPV).Text
For ePV = 1 To ee.Count
eFV = ee.Item(ePV).Text

Out2 = aFV & comm & bFV & comm & cFV & comm & dFV & comm & eFV

Set Out2 = Out2.Offset(1, 0)

Next
Next
Next
Next
Next

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

End Sub

Перед макросом

После макроса Макрос показывает ошибку из-за ограничения столбца