problema al ejecutar programa de permutaciones

[kodashi21]

Hola a todos, resulta q estoy haciendo un ejercicio de permutaciones, tengo el problema q cuando le digito 8 o más el programa sencillamente se queda o se traba, no hace nada, como veran en el codigo, tengo las variables declaradas como double ya q este tipo de dato no me genera error de "desbordamiento", en si lo q quiero es q me muestre las combinaciones de el numero q ingrese pero no logro arreglarlo, porfavor ayudenme lo he revisado y no se q hacerle o si es la memoria . Ojala alguien pudiera ejecutar el codigo q pongo a continuación en su propio computador para saber si es el mio el q esta fallando o si en realidad es un problema de programación:


necesitan un textbox (tnodos), 2 listbox llamadas (lrutas)(vacia), boton llamado ejecutar

Dim aux As Integer
Dim num As Integer
Dim cantidadnodos As Integer
Dim distancia As Integer ' valor entre "a" y "b"
Dim alfabeto As Integer
Dim numero As Integer
Dim casoletra As Integer
Dim i As String
Dim a As Double
Dim b As Double
Dim c As Double
Dim q As Double
Dim ncombinacion As Double

Private Sub Ejecutar_Click()

If Tnodos.Text = "" Then
MsgBox "Debe digitar la cantidad de nodos", , "ERROR"
Tnodos.SetFocus
Else
If Tnodos.Text < 4 Then
MsgBox "El numero de nodos dede ser mayor a 4 ", , "ERROR"
Tnodos.Text = ""
Tnodos.SetFocus
Else
If Tnodos.Text > 26 Then
MsgBox "El numero de nodos dede ser menor 26", , "ERROR"
Tnodos.Text = ""
Tnodos.SetFocus
Else
'Comienza el algoritmo
cantidadnodos = Val(Tnodos.Text)
permutaciones
End If
End If
End If

End Sub


Sub abecedario()
Select Case alfabeto

Case 1
i = "A"
Case 2
i = "B"
Case 3
i = "C"
Case 4
i = "D"
Case 5
i = "E"
Case 6
i = "F"
Case 7
i = "G"
Case 8
i = "H"
Case 9
i = "I"
Case 10
i = "J"
Case 11
i = "K"
Case 12
i = "L"
Case 13
i = "M"
Case 14
i = "N"
Case 15
i = "O"
Case 16
i = "P"
Case 17
i = "Q"
Case 18
i = "R"
Case 19
i = "S"
Case 20
i = "T"
Case 21
i = "U"
Case 22
i = "V"
Case 23
i = "W"
Case 24
i = "X"
Case 25
i = "Y"
Case 26
i = "Z"
End Select
End Sub

Sub permutaciones()
Dim ruta() As String
Dim q As Double
Dim e As Integer, combinacion As Integer, h As Integer
Dim k As Integer, posicion As Integer
Dim f As String, g As String, m As String

ReDim ruta(cantidadnodos)

c = 1
ncombinacion = 1
numero = cantidadnodos - 2

For combinacion = 2 To numero ' la relacion es nodos 4: combi 2*1=2 : bc, cb, nodos 5: combi 3*resuante "2"=6: bcd, bdc,dbc,dcb,cbd,cdb...
ncombinacion = combinacion * ncombinacion
Next combinacion

For a = 1 To ncombinacion
nuevacombinacion:
' posicion del vector 0 q sea a "A"
e = 1
alfabeto = e
abecedario
ruta(0) = i


' posicion final del vector q sea el nodo final
h = (cantidadnodos - 1)
alfabeto = h + 1
abecedario
ruta(h) = i


For posicion = 1 To numero
' aleatorios
Randomize
e = Int((numero * Rnd) + 2)
alfabeto = e
abecedario
ruta(posicion) = i
f = ruta(posicion)
k = posicion

Do
k = k - 1
' Compara hacia atrás, si está repetido genera un nuevo _
número y lo guarda en el índice del vector _
que estaba repetido, es decir en esa posición
g = ruta(k)
If f = g Then
Randomize
e = Int((numero * Rnd) + 2)
alfabeto = e
abecedario
ruta(posicion) = i
f = ruta(posicion)
k = posicion
End If
Loop Until k = 0
Next posicion
e = 0
For e = LBound(ruta()) To UBound(ruta())
vacia.AddItem ruta(e)
Next e

'imprime ruta
m = Join(ruta)
lrutas.AddItem m

If a >= 2 Then ' comparo las rutas, para q no sean iguales

For b = c To (a - 1)
q = (a - 1)
Do
q = q - 1
' Compara hacia atrás, si está repetido genera un nuevo _
número y lo guarda en el índice del vector _
que estaba repetido, es decir en esa posición
If lrutas.List(b) = lrutas.List(q) Then
lrutas.RemoveItem (b)
GoTo nuevacombinacion
End If
Loop Until q = 0
Next b
c = c + 1
End If
Next a
End Sub

[Arielo]

Hola, kodashi21, bienvenid@!!

Primero, te comento algo: el código me resultó muy difícil de leer, debido a la forma en que lo colocaste en el post. En el editor de mensajes, tienes una herramienta que está hecha para colocar código fuente con identación incluida. Sólo tienes que seleccionar todo el código, y pulsar en esta opción: , que se encuentra entre (pegar imagen) y (HTML)



Bien, ahora, al tema:
No le encontré problemas. Lo que pasa es que a partir de 8, genera demasiadas combinaciones. La pc no se cuelga, sino que se encuentra procesando.

Haciéndole unas pocas modificaciones a tu código, podrás ver que esto es así.

Al Form, agregale un Label que se llame "lblcantidad", con un Caption inicial = "0" (cero)
Este label, irá indicando la cantidad de ítems en la ListBox llamada "vacia" (es sólo un número para ver el proceso)

Al sub Ejecutar_Click, le agregué unas líneas (resaltadas en azul)

Private Sub Ejecutar_Click()
lblCantidad = 0
If tnodos.Text = "" Then
	MsgBox "Debe digitar la cantidad de nodos", , "ERROR"
	tnodos.SetFocus
Else
	If tnodos.Text < 4 Then
		MsgBox "El numero de nodos dede ser mayor a 4 ", , "ERROR"
		tnodos.Text = ""
		tnodos.SetFocus
	Else
		If tnodos.Text > 26 Then
			MsgBox "El numero de nodos dede ser menor 26", , "ERROR"
			tnodos.Text = ""
			tnodos.SetFocus
		Else
			'Comienza el algoritmo
			Screen.MousePointer = 11
			lrutas.Clear
			vacia.Clear
			cantidadnodos = Val(tnodos.Text)
			permutaciones
		End If
	End If
End If

Screen.MousePointer = 0
End Sub

Al hacer clic en el botón, lo primero que se hará, es volver a cero el caption de lblcantidad.
"Screen.MousePointer = 11" está para que, cuando comience a crear las combinaciones, en pantalla se vea el reloj de arena.
"Screen.MousePointer = 0" vuelve a mostrar el cursor normal de Windows al finalizar los procesos
"lrutas.clear" y "vacia.clear" están para que, cada vez que se pulse el botón "Ejecutar", se eliminen todos los ítems de cada listbox, así, cada ejecución del programa, comenzará de cero.


Después, agregué las siguientes líneas, en la parte final del sub "Permutaciones" (de nuevo, lo agregado está resaltado con azul):

Do
	k = k - 1
	' Compara hacia atrás, si está repetido genera un nuevo _
	número y lo guarda en el índice del vector _
	que estaba repetido, es decir en esa posición
	If lrutas.List(b) = lrutas.List(q) Then
		lrutas.RemoveItem (b)
		lblCantidad = Val(lblCantidad) + 1
		DoEvents
		GoTo nuevacombinacion
	End If
Loop Until q = 0

De esta manera, cada vez que se remueva un item de lrutas (o sea, cada vez que la comparación de si lrutas.list(b) = lrutas.list(q) sea verdadera), se sumará una unidad en el valor del label lblCantidad.
La instrucción DoEvents está colocada para que vaya mostrando en pantalla el valor de lblCantidad actualizado.

Otra forma de ver que está procesando, sería que cuando parece que ya no está procesando, muevas el cursor de la barra de desplazamiento de la listbox "vacia", hacia el final de la misma, y verás que se siguen agregando ítems.

Bueno, espero que te sirva de algo mi respuesta...

.

[Arielo]

Disculpa que me meta más, pero puedo hacerte una sugerencia.

El Select Case/End Select en la Sub Abecedario, puede ser cambiado por una sola línea de código, haciendo que al valor de la variable alfabeto, se le sume 64 (que es el código ASCII anterior al de la "A")

Sería cambiar todo esto:

Sub abecedario
Select Case alfabeto
	Case 1
	i = "A"
	Case 2
	i = "B"
	Case 3
	i = "C"
	Case 4
	i = "D"
	Case 5
	i = "E"
	Case 6
	i = "F"
	Case 7
	i = "G"
	Case 8
	i = "H"
	Case 9
	i = "I"
	Case 10
	i = "J"
	Case 11
	i = "K"
	Case 12
	i = "L"
	Case 13
	i = "M"
	Case 14
	i = "N"
	Case 15
	i = "O"
	Case 16
	i = "P"
	Case 17
	i = "Q"
	Case 18
	i = "R"
	Case 19
	i = "S"
	Case 20
	i = "T"
	Case 21
	i = "U"
	Case 22
	i = "V"
	Case 23
	i = "W"
	Case 24
	i = "X"
	Case 25
	i = "Y"
	Case 26
	i = "Z"
End Select
End Sub

por esto:

Sub abecedario
	i = Chr$(alfabeto + 64)
End Sub

Saludos!