Estimados,

Tengo una macro que necesito me ayuden por favor a mejorarla.

La macro lo que hace es ver la edad segun la fecha de nacimiento y generar un numero aleatorio supuestamente no repetido, pero al generar nuevos aleatorios si los repite, la macro es la siguiente:

Function CALCULAREDAD(FechaNac As Date)

Dim nacfecha As Date

CALCULAREDAD = Abs(DateDiff("YYYY", FechaNac, Date)) - 1

nacfecha = DateAdd("YYYY", CalcEdad, FechaNac)

If Day(nacfecha) < Day(Date) And Month(nacfecha) = Month(Date) Then

    CALCULAREDAD = CALCULAREDAD + 1

Else

    If Month(Date) > Month(nacfecha) Then

        CALCULAREDAD = CALCULAREDAD + 1

    End If

End If

End Function


Sub AleatoriosNoRepetidosPrueba()

For Each cel In Range("A6:A15")

'CALCULAREDAD (cel.Value)

If CALCULAREDAD(cel.Value) <= 30 Then ini = 1: fin = 201

If CALCULAREDAD(cel.Value) >= 31 And CALCULAREDAD(cel.Value) < 45 Then ini = 202: fin = 347

If CALCULAREDAD(cel.Value) >= 45 Then ini = 350: fin = 365

o:

Num = Application.RandBetween(ini, fin)

On Error Resume Next

Set y = Range("B6:B15").Find(Num, lookat:=xlWhole)

If Not y Is Nothing Then GoTo o

If Not ini = "" Then Range("B" & cel.Row) = Num

Next

End Sub

[/CODE]

Lo que necesito es que al generar los aleatorios los copie en otro lugar para tenerlos como referencia, para que no se vuelvan a repetir al generar nuevos aleatorios, hasta que se termine el rango de números segun la fecha.

Espero me puedan ayudar con esto amigos, realmente no se como hacerlo.

Saludos.

PRUEBA ALEATOREOS POR FECHA DE NAC.rar

.

Creo que funciona:

Sub AleatoriosNoRepetidosPrueba()

For Each cel In Range("A6:A15")

   num = 0

   If CALCULAREDAD(cel.Value) <= 30 Then ini = 1: fin = 201

   If CALCULAREDAD(cel.Value) >= 31 And _

      CALCULAREDAD(cel.Value) < 45 Then ini = 202: fin = 347

   If CALCULAREDAD(cel.Value) >= 45 Then ini = 350: fin = 365

   Do Until num > 0

      num = Application.RandBetween(ini, fin)

      Set y = Range("B6:B15").Find(num, lookat:=xlWhole)

      If Range("B6:B15").Find(num, lookat:=xlWhole) Is Nothing Then

         Range("B" & cel.Row) = num

      Else

         num = 0

      End If

   Loop

Next

End Sub


[/CODE]

Gracias por tu pronta respuesta Marco Antonio, la probé pero si vuelve a repetir los números al generar nuevos aleatorios