Generador de nombres aleatorios sin repetir con visual basic en hojas diferentes

Que se generen las preguntas en hoja 1(menu) y las preguntas estén en hoja 2 (pregunta 1)y hoja 3 (pregunta 2), la idea es que no se repitan las preguntas y que sean de diferentes áreas por eso dos botones y hojas diferentes para que quede el registro, ojala me puedan ayudar.

2

2 respuestas

Respuesta
1

Podría ser algo así

Sub Pregunta1()
Set m = Sheets("menu")
Set p1 = Sheets("Pregunta1")
fila = p1.Cells(1, 3)
If p1.Cells(fila, 1).Value <> "" Then
    m.Range("G2").Value = p1.Cells(fila, 1)
    p1.Cells(1, 3) = fila + 1
    Else
    p1.Cells(1, 3) = 1
    m.Range("G2").Value = p1.Cells(fila, 1)
End If
Exit Sub
End Sub
Sub Pregunta2()
Set m = Sheets("menu")
Set p2 = Sheets("Pregunta2")
fila = p2.Cells(1, 3)
If p2.Cells(fila, 1).Value <> "" Then
    m.Range("G2").Value = p2.Cells(fila, 1)
    p2.Cells(1, 3) = fila + 1
    Else
    p2.Cells(1, 3) = 1
    m.Range("G2").Value = p2.Cells(fila, 1)
End If
Exit Sub
End Sub

Pon la macro Pregunta 1 en el pregunta1(algo logico xD jaja)

Y la macro Pregunta2 en el botón pregunta2

Las preguntas hirian en la columna A a partir de la fila 1 y en C1 se almacenaría el numero de fila que va para poder bajar un lugar cada ves que presiones el botón, y sino encuentra más datos vuelve al principio

Los rangos los puedes modificar a tu necesidad y las hojas ocultarlas para que no se vean si te queda más practico porque la macro simplemente hace referencia a ellas, en ningún momento las selecciona

[quote]

Si te fue útil esta respuesta no olvides valorarla -

Hola gracias por tu ayuda pero copio la macro en el visual asigno al botón y me sale depurardor error 1004 depurador y esto en amarillo If p2.Cells(fila, 1).Value <> "" Then 

Por lo que veo en la imagen, es porque yo le puse "menu", "Pregunta1" y "Pregunta2" y tu tienes los nombres en mayúscula

Recuerda que los nombres en la macro deben ser exactamente iguales a como están escritos en cada hoja

Ejemplo si el nombre de tu hoja es "PrEgUnTa2"

En la macro tiene que decir "Sheets("PrEgUnTa2")"

Prueba revisar eso y me avisas que tal te fue.

PRESIONO EL BOTÓN Y ME LLEVA A ESO, SERA QUE LAS PREGUNTAS LAS ESTOY ASIGNANDO MAL

Era porque tu no ingresaste ningún dato en las celdas donde almacena las filas

Ahora le agregue otra condición, si en esa celda no hay dato o es igual a 0 entonces que le asigne 1 que seria donde empieza tu puedes variarlo arranca antes o después

Sub Pregunta1()
Set m = Sheets("menu")
Set P1 = Sheets("Pregunta1")
If P1.Cells(1, 3).Value = "" Or P1.Cells(1, 3).Value = 0 Then
    P1.Cells(1, 3).Value = 1
End If
fila = P1.Cells(1, 3)
If P1.Cells(fila, 1).Value <> "" Then
    m.Range("G2").Value = P1.Cells(fila, 1)
    P1.Cells(1, 3) = fila + 1
    Else
    P1.Cells(1, 3) = 1
    m.Range("G2").Value = P1.Cells(fila, 1)
End If
Exit Sub
End Sub
Sub Pregunta2()
Set m = Sheets("menu")
Set P2 = Sheets("Pregunta2")
If P2.Cells(1, 3).Value = "" Or P2.Cells(1, 3).Value = 0 Then
    P2.Cells(1, 3).Value = 1
End If
fila = P2.Cells(1, 3)
If P2.Cells(fila, 1).Value <> "" Then
    m.Range("G2").Value = P2.Cells(fila, 1)
    P2.Cells(1, 3) = fila + 1
    Else
    P2.Cells(1, 3) = 1
    m.Range("G2").Value = P2.Cells(fila, 1)
End If
Exit Sub
End Sub
Respuesta
1

Trata esta macro con un solo botón selecciona las preguntas de ambas hojas sin repetirlas

y esta es la macro, solo cambia la referencia de los range por los que tu manejes

Sub aleatorios()
Dim unicos As New Collection
Dim unicos2 As New Collection
Set h1 = Worksheets("menu")
Set h2 = Worksheets("pregunta 1")
Set h3 = Worksheets("pregunta 2")
cuantos = Val(InputBox("cuantas preguntas?"))
h1.range("b6").CurrentRegion.Clear
Set prg1 = h2.range("b2").CurrentRegion
Set prg2 = h3.range("b2").CurrentRegion
f1 = prg1.Rows.Count
f2 = prg2.Rows.Count
For i = 1 To cuantos
    Hoja = WorksheetFunction.RandBetween(1, 2)
    If Hoja = 1 Then f = f1 Else f = f2
otro:
    num = WorksheetFunction.RandBetween(1, f)
    If Hoja = 1 Then
    On Error Resume Next
        unicos.Add num, CStr(num)
        If Err.Number > 0 Then GoTo otro
        h1.range("c6").Cells(i, 0) = prg1.Cells(num, 1)
        On Error GoTo 0
    End If
    If Hoja = 2 Then
        On Error Resume Next
        unicos2.Add num, CStr(num)
        If Err.Number > 0 Then GoTo otro
        h1.range("c6").Cells(i, 0) = prg2.Cells(num, 1)
        On Error GoTo 0
    End If
Next i
Set unicos = Nothing:   Set unicos2 = Nothing
Set h1 = Nothing: Set h2 = Nothing: Set h3 = Nothing
Set prg1 = Nothing: Set prg2 = Nothing
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas