Ayuda con VBA

29/07/2003 - 23:14 por Mario Alberto Rodríguez Soto | Informe spam
Hola.:

Tengo el siguiente código para efectuar obtener pares de números al azar
entre el 1 y el 999, sin embargo, después de ejecutarlo encuentro números
repetidos y no tengo idea de que agregar para evitar esto.

Gracias de antemano.

Mario Alberto

Option Explicit
Option Base 1
Public jj As Long
Public Const iteration = 500
'*****************
'* Resampling Process
*
'*****************

Sub Resample()
Dim i As Long
Dim hold(999) As Single, Hold2(999) As Single
Randomize

For i = 1 To 999
Hold2(i) = i
Next i
For jj = 1 To iteration
For i = 1 To 999
hold(i) = Rnd
Next i
Call DoubleSort(999, hold, Hold2)
For i = 1 To 2
Cells(jj + 3, i) = Hold2(i)
Next i
Next jj
End Sub

'**************************************
'*Sorting Process - Sort array y based on array x
*
'**************************************

Sub DoubleSort(n As Long, x() As Single, y() As Single)
Dim xTemp As Double
Dim yTemp As Double
Dim i As Long
Dim j As Long

For j = 2 To n
xTemp = x(j)
yTemp = y(j)
For i = j - 1 To 1 Step -1
If (x(i) <= xTemp) Then GoTo 10
x(i + 1) = x(i)
y(i + 1) = y(i)
Next i
i = 0
10 x(i + 1) = xTemp
y(i + 1) = yTemp
Next j
End Sub

Preguntas similare

Leer las respuestas

#1 Fernando Arroyo
30/07/2003 - 21:21 | Informe spam
He pensado que mejor que tener que entrar en la lógica del código que has puesto era escribir uno nuevo:

Sub CrearMatrizDobleAleatoria()
Dim wksH As Worksheet
Dim mtr(1 To 2, 1 To 999), n As Byte, j As Integer, intRnd As Integer

Application.ScreenUpdating = False

Set wksH = ThisWorkbook.Worksheets.Add

For n = 1 To 2
wksH.Range("A1:A999") = "=row()"
wksH.Range("A1:A999").Copy
wksH.Range("A1:A999").PasteSpecial Paste:=xlValues, Operation:=xlNone

Application.CutCopyMode = False

For j = 1 To 999

intRnd = Int(((999 + 1 - j) * Rnd) + 1)
mtr(n, j) = wksH.Cells(intRnd, 1)
wksH.Rows(intRnd).Delete

Next j
Next n

'Si lo que necesitas es la matriz, borra o desactiva las siguientes líneas (se encargan de volcar la matriz en la hoja)
For j = 1 To 999
wksH.Cells(j, 1) = mtr(1, j)
wksH.Cells(j, 2) = mtr(2, j)
Next j

'Si lo que necesitas es la matriz, activa las siguientes instrucciones (se encargan de borrar la hoja)
'Application.DisplayAlerts = False
'wksH.Delete
'Application.DisplayAlerts = True

Application.ScreenUpdating = True

Set wksH = Nothing
End Sub


Naturalmente, sólo funcionará en Excel.
Igual está mal que lo diga yo, pero me ha sorprendido lo rápido que es.
Creo que funciona bien porque la suma de cada columna es siempre 499500 y la suma de las diferencias de cada par de elementos es cero, pero tendrás que verificarlo.
Un saludo.


Fernando Arroyo
MS MVP - Excel


"Mario Alberto Rodríguez Soto" escribió en el mensaje news:%
Mostrar la cita
#2 Mario Alberto Rodríguez Soto
30/07/2003 - 22:33 | Informe spam
Gracias Fernando.

El código que me facilitaste funciona muy bien, sin embargo tengo otra
pregunta, que necesito cambiar para que únicamente me de quinientos pares de
números.

Si no mal entendí la lógica seria en:
wksH.Range("A1:A500")
Estoy en lo correcto

De antemano gracias.

Saludos.

"Fernando Arroyo" escribió en el mensaje
news:OWqSb$
He pensado que mejor que tener que entrar en la lógica del código que has
puesto era escribir uno nuevo:

Sub CrearMatrizDobleAleatoria()
Dim wksH As Worksheet
Dim mtr(1 To 2, 1 To 999), n As Byte, j As Integer, intRnd As Integer

Application.ScreenUpdating = False

Set wksH = ThisWorkbook.Worksheets.Add

For n = 1 To 2
wksH.Range("A1:A999") = "=row()"
wksH.Range("A1:A999").Copy
wksH.Range("A1:A999").PasteSpecial Paste:=xlValues,
Operation:=xlNone

Application.CutCopyMode = False

For j = 1 To 999

intRnd = Int(((999 + 1 - j) * Rnd) + 1)
mtr(n, j) = wksH.Cells(intRnd, 1)
wksH.Rows(intRnd).Delete

Next j
Next n

'Si lo que necesitas es la matriz, borra o desactiva las siguientes
líneas (se encargan de volcar la matriz en la hoja)
For j = 1 To 999
wksH.Cells(j, 1) = mtr(1, j)
wksH.Cells(j, 2) = mtr(2, j)
Next j

'Si lo que necesitas es la matriz, activa las siguientes instrucciones
(se encargan de borrar la hoja)
'Application.DisplayAlerts = False
'wksH.Delete
'Application.DisplayAlerts = True

Application.ScreenUpdating = True

Set wksH = Nothing
End Sub


Naturalmente, sólo funcionará en Excel.
Igual está mal que lo diga yo, pero me ha sorprendido lo rápido que es.
Creo que funciona bien porque la suma de cada columna es siempre 499500 y la
suma de las diferencias de cada par de elementos es cero, pero tendrás que
verificarlo.
Un saludo.


Fernando Arroyo
MS MVP - Excel


"Mario Alberto Rodríguez Soto" escribió en el
mensaje news:%
Mostrar la cita
#3 Fernando Arroyo
31/07/2003 - 09:04 | Informe spam
Para que fueran 500 pares habría que cambiar unas cuantas líneas, así que he modificado el código para que se pueda establecer cualquier número de pares. Tan sólo hay que cambiar la primera instrucción.


Private Const intNúmElementos As Integer = 500 'Número de "pares" que tendrá la matriz

Sub CrearMatrizDobleAleatoria()
Dim wksH As Worksheet
Dim mtr(1 To 2, 1 To intNúmElementos), n As Byte, j As Integer, intRnd As Integer

Application.ScreenUpdating = False

Set wksH = ThisWorkbook.Worksheets.Add

For n = 1 To 2
wksH.Range("A1:A" & intNúmElementos) = "=row()"
wksH.Range("A1:A" & intNúmElementos).Copy
wksH.Range("A1:A" & intNúmElementos).PasteSpecial Paste:=xlValues, Operation:=xlNone

Application.CutCopyMode = False

For j = 1 To intNúmElementos

intRnd = Int(((intNúmElementos + 1 - j) * Rnd) + 1)
mtr(n, j) = wksH.Cells(intRnd, 1)
wksH.Rows(intRnd).Delete

Next j
Next n

'Si lo que necesitas es la matriz, borra o desactiva las siguientes líneas (se encargan de volcar la matriz en la hoja)
For j = 1 To intNúmElementos
wksH.Cells(j, 1) = mtr(1, j)
wksH.Cells(j, 2) = mtr(2, j)
Next j

'Si lo que necesitas es la matriz, activa las siguientes instrucciones (se encargan de borrar la hoja)
'Application.DisplayAlerts = False
'wksH.Delete
'Application.DisplayAlerts = True

Application.ScreenUpdating = True

Set wksH = Nothing
End Sub


Un saludo.


Fernando Arroyo
MS MVP - Excel


"Mario Alberto Rodríguez Soto" escribió en el mensaje news:%
Mostrar la cita
#4 Fernando Arroyo
01/08/2003 - 17:05 | Informe spam
Pero ¿qué entiendes por "sin que se repitan los números"?:
- que un número que está en la "columna" 1 de la matriz no pueda estar en la "columna" 2, es decir, necesitas distribuir de forma aleatoria los números del 0 al 999 en dos listas de 500
- o que un número no pueda estar más de una vez en cada una de las "columnas" de la matriz, pero sí pueda estar en ambas
Un saludo.


Fernando Arroyo
MS MVP - Excel


"Mario Alberto Rodríguez Soto" escribió en el mensaje news:
Mostrar la cita
#5 Fernando Arroyo
01/08/2003 - 21:53 | Informe spam
Ahora sí que creo que no se nos escapa: lo tenemos rodeado :-)
Prueba con:


Private Const intNúmElementos As Integer = 500 'Número de "pares" que tendrá la matriz

Sub CrearMatrizDobleAleatoria()
Dim wksH As Worksheet
Dim mtr(1 To 2, 1 To intNúmElementos), j As Integer, intRnd As Integer

Application.ScreenUpdating = False

Set wksH = ThisWorkbook.Worksheets.Add

wksH.Range("A1:A" & intNúmElementos * 2) = "=row()"
wksH.Range("A1:A" & intNúmElementos * 2).Copy
wksH.Range("A1:A" & intNúmElementos * 2).PasteSpecial Paste:=xlValues, Operation:=xlNone

Application.CutCopyMode = False

For j = 1 To intNúmElementos * 2

intRnd = Int((((intNúmElementos * 2) + 1 - j) * Rnd) + 1)
mtr(IIf(j <= intNúmElementos, 1, 2), IIf(j <= intNúmElementos, j, j - intNúmElementos)) = wksH.Cells(intRnd, 1) - 1
wksH.Rows(intRnd).Delete

Next j

'Si lo que necesitas es la matriz, borra o desactiva las siguientes líneas (se encargan de volcar la matriz en la hoja)
For j = 1 To intNúmElementos
wksH.Cells(j, 1) = mtr(1, j)
wksH.Cells(j, 2) = mtr(2, j)
Next j

'Si lo que necesitas es la matriz, activa las siguientes instrucciones (se encargan de borrar la hoja)
'Application.DisplayAlerts = False
'wksH.Delete
'Application.DisplayAlerts = True

Application.ScreenUpdating = True

Set wksH = Nothing
End Sub


Un saludo.


Fernando Arroyo
MS MVP - Excel



"Mario Alberto Rodríguez Soto" escribió en el mensaje news:
Mostrar la cita
Ads by Google
Search Busqueda sugerida