Extraer números aleatorios de un rango variable, para algunas celdas y si cumplen ciertas condiciones con VBA
Esta es la continuación de una pregunta anterior donde me ayudaron a extraer números aleatorios de un rango de celdas pero que solo fura de una fila y no de toda la hoja. En mi pregunta anterior llamada "ACTUALIZAR FÓRMULAS ESPECIFICAS POR VBA Y NO TODA LA HOJA" esa duda quedo solucionada pero se extendió a esta otra pregunta un poco más profunda, explico la situación.
Solicito ahora en este tema. Ya que necesito extraer números al azar o aleatorios sin repetir de un rango de números. Pero no siempre son la misma cantidad de números. Max pueden ser 15 y mínimo 2 números en el rango, si en el rango se cumple la condición que hay 15 números debe extraer una cantidad de números que se le indique en una celda. Subiré un pantallazo para ser más explicito, donde básicamente si en la columna de la celda AF que es la columna que dice cuantos números hay en el rango y la celda AG es donde dice cuantos números se deben extraer, esta relación nunca cambia si en AF dice 15 en AG siempre va a estar ese numero y así sucesivamente.
Cabe aclarar que debe funcionar como la macro de la pregunta anterior que solo actualize por fila y no toda la hoja, solo hay que incrementarle ese cambio para que extraiga la cantidad de números variables de acuerdo a la cantidad de números que hay en el rango
Mil gracias bendiciones
2 respuestas
Te anexo la macro 2
Sub aleatorio_2()
'Por Dante Amor
Dim num As New Collection
On Error Resume Next
fila = ActiveCell.Row
ini = Columns("Q").Column 'columna inicial
fin = ini + Cells(fila, "AF").Value - 1 'columna final
col = Columns("AH").Column 'columna resultados
n = Cells(fila, "AG").Value
'
Do While num.Count < n
columna = WorksheetFunction.RandBetween(ini, fin)
valor = Cells(fila, columna).Value
num.Add Item:=valor, Key:=CStr(valor)
Loop
For i = 1 To num.Count
Cells(fila, col).Value = num(i)
col = col + 1
Next
MsgBox "Fin"
End Sub'.[Sal u dos. Dante Amor. No olvides valorar la respuesta. '.[Avísame cualquier duda
¡Gracias! Totales...
Hola Dante buenas tardes.
de nuevo por aquí a molestarte. si a esta macro que me enviaste quisiera que funcionara en un rango que seleccione y no una por una. que tendríamos que añadirle?
como me la pasaste, se le indica a la macro que funcione de acuerdo a la fila en donde este posicionado el cursor y fila por fila.
PERO para agilizar una base de datos que tengo y no hacerlo uno por uno. podríamos anexar algo para que arroje los resultados de un rango seleccionado?
quedo atento y mil gracias, si necesitas que abra otra pregunta para ayudarme con la respuesta con gusto lo hago. mil gracias...
Crea una nueva pregunta y ahí me explicas cómo o cuáles filas seleccionarías
¡Gracias! Dante te adjunto link de la nueva pregunta. mil gracias
Extraer números aleatorios de un rango de números variables con macro
Quizá lo que buscas es esto, este es el resultado de 3 macros que actúan en conjunto una genera los números aleatorios del rango A al O, una lee los números del rango q2 al AE15 y les asigna los veces que generara los números aleatorios y la tercera asocia a los resultados de las 2 para generate las combinaciones.
y estas son las macros, traen un generador de números aleatorios para usar una semilla o numero base diferente cada vvez que se genera uno.
Option Base 1
Sub EJECUTA()
numeros_aleatorios
GENERA_ALEATORIOS
ASOCIA_TABLAS
End Sub
Sub numeros_aleatorios()
Dim funcion As WorksheetFunction
Set funcion = WorksheetFunction
Set datos = Range("q2").CurrentRegion
With datos
C = .Columns.Count: R = .Rows.Count
mayor15 = C > 15
If mayor15 Then: Set datos = .Resize(R, 15)
For I = 1 To R
cuenta = funcion.CountA(.Rows(I))
cantidad = funcion.Choose(cuenta, 0, 1, 1, 2, 2, 2, 3, 3, 4, 4, 4, 5, 5, 6, 6)
.Cells(I, 16) = cuenta
.Cells(I, 17) = cantidad
Next I
.CurrentRegion.EntireColumn.AutoFit
End With
End Sub
Sub GENERA_ALEATORIOS()
Dim UNICOS As New Collection
Range("A2").CurrentRegion.ClearContents
Set datos = Range("Q2").CurrentRegion
With datos
R = .Rows.Count: C = .Columns.Count
For I = 1 To R
NUMERO = .Cells(I, 16)
If I = 1 Then Set TPROB = Range("A2").Resize(1, NUMERO)
If I > 1 Then
Set TPROB = TPROB.CurrentRegion
RR = TPROB.Rows.Count
Set TPROB = TPROB.Rows(RR + 1).Resize(1, NUMERO)
End If
Set UNICOS = Nothing
For J = 1 To NUMERO
otro:
Randomize
Prob = Rnd
On Error Resume Next
UNICOS.Add Prob, CStr(Prob)
If Err.Number > 0 Then GoTo otro:
TPROB.Cells(1, J) = Prob
On Error GoTo 0
Next J
Next I
End With
Set datos = Nothing: Set TPROB = Nothing
End Sub
Sub ASOCIA_TABLAS()
Dim funcion As WorksheetFunction
Set funcion = WorksheetFunction
Set datos = Range("q2").CurrentRegion
Set TPROB = Range("A2").CurrentRegion
With datos
R = .Rows.Count: C = .Columns.Count
.Columns(C + 3).CurrentRegion.ClearContents
For I = 1 To R
NUMERO = .Cells(I, 16)
VECES = .Cells(I, 17)
Set FILA = TPROB.Rows(I).Resize(1, NUMERO)
Set FILA2 = datos.Rows(I).Resize(1, NUMERO)
If I = 1 Then Set RES = .Columns(C + 3).Resize(1, VECES)
If I > 1 Then
Set RES = RES.CurrentRegion
RR = RES.Rows.Count
Set RES = RES.Rows(RR + 1).Resize(1, VECES)
End If
For J = 1 To VECES
XP = funcion.Small(FILA, J)
INDICE = funcion.Match(XP, FILA, 0)
NUMERO2 = FILA2.Cells(1, INDICE)
RES.Cells(1, J) = NUMERO2
Next J
Next I
RES.CurrentRegion.EntireColumn.AutoFit
End With
Set funcion = Nothing: Set datos = Nothing
Set TPROB = Nothing: Set RES = Nothing
End Sub