Cuantos números de 4 cifras pueden salir en excel

Cuantas numerosde 4 cifras pueden salir combinando las 12 casillas en excel y si hay alguna manera de combinarlos con alguna macro o formula

2

2 Respuestas

0 pts. en busca de lo imposible

Me di a la tarea de buscar y encontré esta macro que funciona de maravilla

Sub genera_Variaciones_ejemplo_hoja_Consulta()
Dim Vec, Q&, i&, C As Range

[f1].CurrentRegion.Delete xlShiftUp
Application.ScreenUpdating = False

With [a1].CurrentRegion
Q = .Count: ReDim Vec(1 To Q)
For Each C In .Cells: i = 1 + i: Vec(i) = C: Next

Application.Run "Hoja82.c_v_Determinación", Vec, Q, 4, "V"
Application.ScreenUpdating = False

ActiveSheet.[a1].CurrentRegion.Copy .Worksheet.[f1]
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End With

Application.ScreenUpdating = True
End Sub

Sub Combinaciones_Variaciones()
Dim Vec, iniTime!

iniTime = Timer
[a7] = ""

Application.ScreenUpdating = False
Vec = Application.Transpose(Range("c2", [c1].End(xlDown)))
c_v_Determinación Vec, UBound(Vec), [a4], UCase(Left([a1], 1))

[a7] = "generados en " & Format(Timer - iniTime, "0.0000") & " seg."
Application.ScreenUpdating = True
End Sub

Private Sub c_v_Determinación(Vec1, NN&, MM%, Tipo$)
'------------------
'by Cacho Rodríguez
'------------------
Dim qCeldas#

If MM < 1 Then Msg 1
If NN < MM Then Msg 2

qCeldas = CDbl(ActiveSheet.Rows.Count) * CDbl(ActiveSheet.Columns.Count)

If Tipo = "C" And Application.Combin(NN, MM) > qCeldas Then Msg 3
If Tipo = "V" And Application.Permut(NN, MM) > qCeldas Then Msg 3

With ActiveCell
Set ws = Worksheets.Add(after:=.Worksheet)
Application.GoTo .Cells, False
End With

If Tipo = "C" Then
Combinaciones Vec1, NN, MM
ElseIf Tipo = "V" Then
Variaciones Vec1, NN, MM
End If

Application.GoTo ws.Cells(1), True
End Sub

Private Sub Combinaciones(Vec1, NN&, MM%, Optional V As Boolean = False)
Dim Vec2, i%, piv%, r_Mat&, Vec3

ReDim Mat(1 To mMat, 1 To 1)

If V Then
Close
Open Environ("Temp") & "\CachoR.txt" For Output As #82
Else
iRow = 1: iCol = 1
End If

ReDim Vec2(1 To MM)
ReDim Vec3(1 To MM)

For i = 1 To MM
Vec2(i) = i
Next
piv = MM: r_Mat = 0

Do
For i = 1 To MM
Vec3(i) = Vec1(Vec2(i))
Next

r_Mat = 1 + r_Mat
Mat(r_Mat, 1) = Join(Vec3, "|")

If r_Mat = mMat Then
Guardar r_Mat, V
r_Mat = 0
End If
Vec2(piv) = 1 + Vec2(piv)
If Vec2(piv) > NN Then
Do
If piv = 1 Then
Guardar r_Mat, V
Exit Sub
End If
piv = piv - 1
If Vec2(piv) < NN - (MM - piv) Then Exit Do
Loop
Vec2(piv) = 1 + Vec2(piv)
For i = 1 + piv To MM
Vec2(i) = 1 + Vec2(i - 1)
Next
piv = MM
End If
Loop

End Sub

Private Sub Variaciones(Vec1, NN&, MM%)
Dim Vec2, r_Mat&, iLine, i&, j%, Vec3

Combinaciones Vec1, NN, MM, True
Close #82

Vec2 = Permutaciones(MM)
ReDim Vec3(1 To MM)
ReDim Mat(1 To mMat, 1 To 1)

Open Environ("Temp") & "\CachoR.txt" For Input As #82
r_Mat = 0
iRow = 1: iCol = 1

Do Until EOF(82)
Line Input #82, iLine
iLine = Split(iLine, "|")
For i = 1 To UBound(Vec2)
For j = 1 To MM
Vec3(j) = iLine(Vec2(i, j) - 1)
Next
r_Mat = 1 + r_Mat
Mat(r_Mat, 1) = Join(Vec3, "|")
If r_Mat = mMat Then
Guardar r_Mat, False
r_Mat = 0
End If
Next
Loop

If r_Mat > 0 Then Guardar r_Mat, False

End Sub

Private Function Permutaciones(Q%)
Dim Vec1, Vec2, i&, piv%, R&, j%, k&

ReDim Vec2(1 To 1, 1 To 1)
Vec2(1, 1) = 1

Do Until UBound(Vec2, 2) = Q
Vec1 = Vec2
ReDim Vec2(1 To UBound(Vec1, 1) * (1 + UBound(Vec1, 2)), 1 To (1 + UBound(Vec1, 2)))

For i = 1 To UBound(Vec2, 1)
k = 1 + (i - 1) Mod UBound(Vec2, 2)
For j = 1 To UBound(Vec2, 2)
Select Case True
Case k < j
Vec2(i, j) = Vec1(1 + Int((i - 1) / UBound(Vec2, 2)), j - 1)
Case k = j
Vec2(i, j) = UBound(Vec2, 2)
Case k > j
Vec2(i, j) = Vec1(1 + Int((i - 1) / UBound(Vec2, 2)), j)
End Select
Next
Next
Loop

Permutaciones = Vec2

End Function

Private Sub Guardar(r_Mat&, V As Boolean)
Dim i&

'DoEvents
On Error GoTo eTrap
If V Then
For i = 1 To r_Mat
Print #82, Mat(i, 1)
Next
Else
ws.Cells(iRow, iCol).Resize(r_Mat) = Mat
iRow = iRow + r_Mat
End If
On Error GoTo 0
Exit Sub

eTrap:
iRow = 1: iCol = 1 + iCol
Resume
End Sub

Private Sub Msg(Caso%)
Dim iMsg$

Select Case Caso
Case 1: iMsg = "El número de elementos de cada grupo" & vbLf & "debe ser un entero mayor que cero."
Case 2: iMsg = "El número de elementos de cada grupo" & vbLf & "NO debe ser mayor al número total de elementos."
Case 3: iMsg = "El número de grupos a generar supera a la cantidad de celdas de la hoja."
End Select

MsgBox iMsg
End
End Sub

63.275 pts. Si de mis mayores gustos, mis disgustos han nacido,...

Para permutaciones son 20,736 arreglos posibles, para combinaciones son 495 arreglos únicos y la macro para conseguir todos los arreglos posibles en ambos con la siguiente macro consigues ambos arreglos en un solo paso dura menos de 1 minuto generar todos los arreglos

Sub genera_permutacionycombina()
Set DATOS = Range("a1").CurrentRegion
FILAS = DATOS.Cells.Count

Permutaciones = 12 ^ 4
Combinaciones = WorksheetFunction.Combin(FILAS, 4)

With Range("F1")
.Value = "PERMUTACIONES TOTALES: " & Permutaciones
.Font.Bold = True
End With

With Range("F2")
.Value = "COMBINACIONES TOTALES: " & Combinaciones
.Font.Bold = True
End With

Set PERMUTA = Range("F6").Resize(Permutaciones, 4)
Set COMBINA = Range("K6").Resize(Combinaciones, 4)

MATRIZ = PERMUTA: MATRIZA = COMBINA

X = 1: Y = 1
For a = 1 To 12
For B = 1 To 12
For C = 1 To 12
For D = 1 To 12
On Error Resume Next
MATRIZ(X, 1) = DATOS.Cells(a)
MATRIZ(X, 2) = DATOS.Cells(B)
MATRIZ(X, 3) = DATOS.Cells(C)
MATRIZ(X, 4) = DATOS.Cells(D)
If B > a And C > B And D > C Then
MATRIZA(Y, 1) = DATOS.Cells(a)
MATRIZA(Y, 2) = DATOS.Cells(B)
MATRIZA(Y, 3) = DATOS.Cells(C)
MATRIZA(Y, 4) = DATOS.Cells(D)
Y = Y + 1
End If
On Error GoTo 0
X = X + 1
Next D
Next C
Next B
Next a
Range(PERMUTA.Address) = MATRIZ
Range(COMBINA.Address) = MATRIZA
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas