Problema con VBA que extrae aleatorios de un Rango
Sub aleatorio()
'Por Dante Amor
Dim cadafila As Range, fila As Long, ini As Long, fin As Long
Dim n As Variant, columna As Variant, valor As Variant
Dim col As Long, sh As Worksheet, i As Long
Dim num As New Collection
Set sh = Sheets("Hoja1")
On Error Resume Next
For Each cadafila In Selection.Rows
Set num = Nothing
fila = cadafila.Row
ini = Columns("A").Column 'rango inicial
fin = ini + sh.Cells(fila, "AD").Value - 1 'rango final
col = Columns("AG").Column 'columna resultados
n = sh.Cells(fila, "AE").Value 'valor cant aleatorios
'
Do While num.Count < n
columna = WorksheetFunction.RandBetween(ini, fin)
valor = sh.Cells(fila, columna).Value
num.Add Item:=valor, Key:=CStr(valor)
Loop
For i = 1 To num.Count
sh.Cells(fila, col).Value = num(i)
col = col + 1
Next
Next
End Submuy buenas noches. La macro anterior fue proporcionada por un experto muy colaborador de esta pagina del cual me encuentro muy agradecido por su ayuda.
La macro trabaja muy bien, pero cuando se presenta en ciertas situaciones se queda pegada y no corre más. Como ilustro en la imagen, la macro extrae aleatoriamente datos de el rango y en la columna "AE" le dice que extraiga en este caso 5 datos aleatoriamente. Y los empiece a pegar a partir de la columna AG, aclaro que la macro trabaja solo la fila donde yo este activo, y en la hoja que este configurada en la macro, en este caso la hoja1. Independientemente de q hoja me encuentre en el libro. El tema es que la macro trabaja bien, pero en las filas q tienen datos completos en el rango.
En la imagen coloque 2 filas: la fila 3, tiene todos los datos llenos hasta la columna "AD" y como se puede apreciar en la foto, allí la ejecute y saco aleatoriamente los 5 números sin problemas. Todo perfecto :)
PERO si la ejecuto en una fila como es la fila 4, como se ve en la imagen, vemos que esta solo tiene datos hasta la columna "T", y así este vacío una sola fila en ese rango, la macro se queda pensando y el libro (no responde) y la única manera es forzar cerrado del libro.
¿Hay alguna manera de que la macro extraiga los datos así no este totalmente lleno el rango?
Dado el caso de que sea muy complicado, pienso en hacer una macro "extra" q reemplace esos valores vacíos por un valor "000" y luego a esta macro de aleatorio, modificarla para que extraiga pero indicándole que ignore ese valor "000" para que no los vaya a incluir en el aleatorio.
Es una opción que doy por si el arreglo a la macro es muy complicado :)
1 Respuesta
Te cambio la macro por una nueva
Sub Aleatorios()
Dim i As Long, j As Long, n As Long, m As Long, r As Range
Dim idx As Long, tmp As Variant, arr As Variant
'
i = ActiveCell.Row
Set r = Range("A" & i & ":AD" & i)
n = WorksheetFunction.CountA(r)
m = Range("AE" & i)
arr = Evaluate("=ROW(1:" & n & ")")
'
For j = 1 To m
idx = WorksheetFunction.RandBetween(1, n)
tmp = arr(idx, 1)
arr(idx, 1) = arr(j, 1)
arr(j, 1) = tmp
Next
Range("AG" & i).Resize(1, m).Value = Application.Index(r, , Application.Transpose(arr))
End Sub
Dante falto una ultima cosa que te mencione!!.. la macro anterior funcionaba en una hoja en especifico "hoja1" asi yo no estuviera en esa hoja, ya que al momento de ejecutar la macro no me encuentro en esa hoja.
osea si estoy en la fila 5 de cualquier hoja, la macro se ejecute pero solamente en "hoja1" ya que en esa hoja se encuentran los datos.
de resto funciona perfecta y ya no se queda pegada..
mil gracias :) y disculpa las molestias
Prueba esto:
Sub Aleatorios()
Dim i As Long, j As Long, n As Long, m As Long, r As Range
Dim idx As Long, tmp As Variant, arr As Variant, sh As Worksheet
'
Set sh = Sheets("Hoja1")
i = ActiveCell.Row
Set r = sh.Range("A" & i & ":AD" & i)
n = WorksheetFunction.CountA(r)
m = sh.Range("AE" & i)
arr = Evaluate("=ROW(1:" & n & ")")
'
For j = 1 To m
idx = WorksheetFunction.RandBetween(1, n)
tmp = arr(idx, 1)
arr(idx, 1) = arr(j, 1)
arr(j, 1) = tmp
Next
sh.Range("AG" & i).Resize(1, m).Value = Application.Index(r, , Application.Transpose(arr))
End Sub
¡Gracias! muchisimas muchisimas y muchisimas gracias. que espectacular persona eres. siempre dispuesto ayudar.. Dios te bendiga Dante
feliz noche
Me encanta ayudar, g racias por comentar.
Hola dante buenas tardes, espero te encuentres bien.
Quería hacerte una consulta referente a esta macro, si en la columna AE que es la que le indica a la macro la cantidad de datos a extraer del rango, dado el caso le coloco "0", ya que en ciertas ocasiones no necesito sacar aleatorios del rango, esta macro arroja error '1004'
Realmente no lo mencione ya que la macro anterior cuando en ocasiones no necesitaba datos a extraer, le colocaba "0" y simplemente no extraía datos y no presentaba error. Y ahora probándola en diferentes circunstancias me percate de ello, :/
Si solo hay que adicionarle algún dato y es corto me indicas, si tienes que hacer otra macro con gusto hago otra pregunta...:) gracias
No probado, pero debe funcionar
Sub Aleatorios()
Dim i As Long, j As Long, n As Long, m As Long, r As Range
Dim idx As Long, tmp As Variant, arr As Variant, sh As Worksheet
'
Set sh = Sheets("Hoja1")
i = ActiveCell.Row
Set r = sh.Range("A" & i & ":AD" & i)
n = WorksheetFunction.CountA(r)
m = sh.Range("AE" & i)
if m > 0 then
arr = Evaluate("=ROW(1:" & n & ")")
'
For j = 1 To m
idx = WorksheetFunction.RandBetween(1, n)
tmp = arr(idx, 1)
arr(idx, 1) = arr(j, 1)
arr(j, 1) = tmp
Next
sh.Range("AG" & i).Resize(1, m).Value = Application.Index(r, , Application.Transpose(arr))
end if
End Sub
Hola Dante, una duda que consigo con la función Evaluate - Adriel Ortiz Mangia
La función Evaluate es para convertir un nombre de excel a un objeto o a un valor. En este caso estoy creando un arreglo con 1 a n items y al mismo tiempo llena el arreglo con los valore 1,2,3, hasta n. Revisa lo siguiente: https://docs.microsoft.com/en-us/office/vba/api/excel.application.evaluate - Dante Amor
Evaluate, si no es la más, es una de las más poderosas funciones de VBA. - Andy Machin
Muchas gracias Dante y Andy bendiciones - Adriel Ortiz Mangia