Mensajes

Entonces no es mi funcion lo que necesitas.

No se me ocurría por donde pillarlo, asi que he usado una sub recursiva muy chula que nos dejó seba123neo, con algunas modificaciones.

Aquí está la sub original:
http://foro.elhacker.net/programacion_vb/combinaciones_vb-t240009.0.html

Y esto es lo que he sacado:

Hace falta un command button y un listbox.

Código (vb) [Seleccionar] Expandir

Option Explicit
Private Sub Command1_Click()
  Dim F As Long
  Dim F2 As Long
  Dim Matriz1() As String
  Dim Matriz2() As String
  Dim MatrizFinal() As String
  Dim Linea As String
  Dim Contador As Long
  Dim ListaElementos As String
 
  List1.Clear
 
  ListaElementos = "AA,BB,CC,15,EE,20,GG,01" ' max. 10 elementos

  Matriz1 = Split(ListaElementos, ",") 'separamos los elementos
  For F = 0 To UBound(Matriz1) ' creamos una linea con X numeros
    Linea = Linea & CStr(F)
  Next F
 
  ReDim Matriz2(0)
  Call Combinaciones(Linea, Matriz2) ' creamos la matriz con las combinaciones de los X numeros
 
  ReDim MatrizFinal(0)
  For F = 0 To UBound(Matriz2) - 1
    Linea = ""
    For F2 = 1 To UBound(Matriz1) + 1 ' reemplazamos los numeros por los elementos de la lista
      Linea = Linea & Matriz1(Val(Mid$(Matriz2(F), F2, 1))) & ","
    Next F2
    ReDim Preserve MatrizFinal(Contador)
    MatrizFinal(Contador) = Left(Linea, Len(Linea) - 1) 'guardamos quitando la ultima coma
    Contador = Contador + 1
  Next F
 
  ' mostramos el resultado
  MsgBox "Total " & Contador & " grupos" ' mostramos la cantidad de grupos extraidos
  For F = 0 To UBound(MatrizFinal)
    List1.AddItem MatrizFinal(F) ' y los cargamos en el listbox
  Next F
 
 
End Sub

Private Sub Combinaciones(Palabra As String, ByRef Matriz() As String, Optional strFixed As String)

    Dim i As Integer

    If Len(Palabra) > 1 Then

        For i = 1 To Len(Palabra)

            Combinaciones Left$(Palabra, i - 1) & Mid$(Palabra, i + 1), Matriz, strFixed & Mid$(Palabra, i, 1)

        Next i

    Else
        Matriz(UBound(Matriz)) = strFixed & Palabra
        ReDim Preserve Matriz(UBound(Matriz) + 1)

    End If

End Sub

A la sub de seba123neo solo le he añadido una matriz donde ir dejando los grupos que luego convertiremos segun nuestra necesidad.
Es mejor usar matrices porque un listbox tiene más limitaciones de capacidad.

Espero que te sirva.
Saludos

Hola Arturoro.
No tengo muy claro lo que explicas ni como te ha salido el numero 40320.
Las combinaciones sin repetición de 8 elementos en grupos de 2 creo que serian algo como 7+6+5+4+3+2+1
En tu ejemplo:
7
AA,BB
AA,CC
AA,15
AA,EE
AA,20
AA,GG
AA,01
6
BB,CC
BB,15
BB,EE
BB,20
BB,GG
BB,01
5
CC,15
CC,EE
CC,20
CC,GG
CC,01
4
15,EE
15,20
15,GG
15,01
3
EE,20
EE,GG
EE,01
2
20,GG
20,01
1
GG,01

El problema que veo es que pones grupos de 8 donde deberias poner un 2
Public TamGrupos As Integer = 8 ' Tamaño de los grupos
De modo que solo te muestra 1 grupo con los 8 elementos

Saludos

Supongo que solo te falta añadir una linea para conseguir el valor que buscas.
Algo así en esta zona:

Código (vb) [Seleccionar] Expandir

Do While fich2.atEndOfStream <> True
 linea2=fich2.ReadLine
' Ahora mostramos la línea leída
 wscript.echo linea2
' Parseamos los campos
 campos = split(linea2,"#")
 for each b in campos
   wscript.echo "valor del campo: "&b
 next

 if campos(0)=linea then valorbuscado=campos(1): exit do

Loop

wscript.echo linea
wscript.echo linea2

wscript.echo valorbuscado



Saludos

Despues de cerrar las ventanas con unload añade End y se cerrara el programa.
Algo asi:

Código (vb) [Seleccionar] Expandir

Unload form2
Unload form1
End

Saludos

Algo debo estar haciendo mal, porque mi nombre no aparece en la lista de errores  

Código (vb) [Seleccionar] Expandir

Private Function IsNumeric_PKJ(Cadena As String) As Boolean
 Dim Valor As Variant
 On Error GoTo Error1
 Valor = CDbl(Cadena)
 IsNumeric_PKJ = True
Error1:
End Function

O eso o 7913+pkj = 1Genius
EDIT: No, ahora me estoy fijando que 7913 no necesita socios
Su nombre tampoco aparece en la lista de fallos.
EDIT2:
En realidad hemos pensado lo mismo pero al revés.
Supongo que parece que lo he copiado, pero ha sido pura casualidad.
Intentaré buscar otro modo, aunque ya digo que esto esta muy trillado.

EDIT3:
Lo siento. Solo se me ocurren variantes de lo mismo.
Si lo que quiero es saber si es un número no se me ocurre nada mejor que esto, y ya que funciona creo que me conformaré:

Código (vb) [Seleccionar] Expandir

Private Function IsNumeric_PKJ(Cadena As String) As Boolean
  On Error GoTo Error1
  If CDbl(Cadena) = 0 Or CDbl(Cadena) <> 0 Then IsNumeric_PKJ = True
Error1:
End Function


Por cierto, pensaba que ninguna funcion superaba el test y resulta que hay varias que tampoco dan errores, solo que como no dan errores pasan desapercibidas y no lo habia notado. Por eso cuando me ha funcionado a la primera no me lo creia.
Copie la funcion de 7913 para evitarme escribir el encabezado y cuando vi que era parecida a lo que queria hacer, pense que habia mejorado esa funcion, cuando de por si ya funcionaba.
En fin, creo que darle mas vueltas es complicarse la vida.

Saludos

Si gustas retos aquí tienes:

http://foro.elhacker.net/programacion_visual_basic/recopilacion_de_retos_vbclassic_por_79137913-t360748.0.html;msg1743290#msg1743290

Es lo que me animó a poner el reto.
Estuve mirando, e incluso he comentado algo, pero en general acabo mareado si intento descifrar los codigos
Trabajais con cosas que nunca he visto o que no entiendo y me hago un lio.

Si puedes superar esta te ganas mi respeto .

He echado un vistazo y me parece que teneis el tema bien trillado. No creo que se me ocurra nada nuevo. Ni siquiera he usado nunca esa función IsNumeric
De todos modos, al menos lo voy a pensar. Igual salta la liebre.

Saludos

Buen trabajo, BlackZeroX, algo tarde pero muy bueno.

Solo he tenido que retocarla un pelín y es mucho mas rápida que la de muestra.
Parece incluso más rápida que la más rápida que he hecho yo

Código (vb) [Seleccionar] Expandir


Function DimeQueHagoB(ByVal Valor1 As Long, ByVal Valor2 As Long, Bits As Byte) As Integer

  Dim lV3 As Long

  Dim iCount As Byte

  lV3 = (Valor1 Xor Valor2)

  If lV3 = 0 Then Exit Function

  If (Bits > 32) Then Bits = 32

  For iCount = 1 To Bits

    If (lV3 And &H1) Then

      DimeQueHagoB = DimeQueHagoB + 1

    ElseIf (lV3 = 0) Then

      Exit For

    End If

    lV3 = lV3 \ 2
 
  Next iCount

End Function


En VB6 un Long tiene 32 bits, en VB.Net creo que son 64

¿Veis los demás como solo era ponerse?

Saludos

Vaya decepción. Parece que ni siquiera lo habéis intentado.

Lo explicaré brevemente para no haceros perder vuestro tiempo. Las hice para un programa de reducciones 1X2.

La segunda función, la pequeña, compara 2 números binarios a partir de sus equivalentes decimales y devuelve las diferencias. Compara 2 dobles a partir de sus números de orden.

La primera función, la grande, hace lo mismo pero con 2 valores que representan dos potencias de 3. Compara 2 triples.

Las dos se pueden mejorar mucho, pero no voy a entrar en detalles.

Saludos

Para los que quieran intentarlo, aquí os dejo una pista.

Esta es su hermanita pequeña. La otra me costó más sacarla (que borrico).

Código (vb) [Seleccionar] Expandir


Function DimeQueHagoB(ByVal Valor1 As Long, ByVal Valor2 As Long, Bits As Integer) As Integer
  Dim Valor3 As Long
  Dim F As Integer
 
  Valor3 = (Valor1 Xor Valor2)
 
  For F = 0 To Bits - 1
    If Valor3 And (2 ^ F) Then DimeQueHagoB = DimeQueHagoB + 1
  Next F
 
End Function


Las dos las tengo ya mejoradas reemplazando las operaciones mas gordas por sus resultados.
Mas código pero más velocidad.

Espero que con esto al menos sepáis lo que son los Trits

Saludos

Quiero proponeros una adivinanza y un reto:

Adivinanza: ¿Que hace esta función que he inventado?
Os dejo las variables con nombres descriptivos para que podais seguirla mejor.
Los mas iniciados seguro que lo adivinan en un vistazo y se ríen de mis métodos.
El caso es que a veces se me enciende la bombilla, pero parpadea mucho

Reto: Mejorar esta función. Fácil.

No es que tenga demasiado interés en que sea más rápida, aunque me gustaría ver el sistema que usaría alguien con conocimientos de matemáticas (o igual hay una API para esto ). Yo en el colegio nunca presté atención

He pensado que son dos buenos retos.

Espero que os animéis muchos.
Si se me ocurre como, yo también la intentaré mejorar (bueno, mas rápido ya se me está ocurriendo: puedo quitar los xor si copio 2 veces el código... o quizás no).

Haced vuestras propias versiones una vez que sepais lo que hace.

Código (vb) [Seleccionar] Expandir


Function DimeQueHago(ByVal Valor1 As Long, ByVal Valor2 As Long, Trits As Integer) As Long
 Dim Acu As Integer
 Dim Bloque As Long
 Dim Bloque2 As Long
 Valor1 = Valor1 + 1 ' yo lo uso sin
 Valor2 = Valor2 + 1 ' estas 2 lineas
 If Valor2 > Valor1 Then
   Valor1 = Valor1 Xor Valor2
   Valor2 = Valor1 Xor Valor2
   Valor1 = Valor1 Xor Valor2
 End If
 Bloque = (3 ^ Trits) / 3
 Do Until Bloque = 1
   Bloque2 = Bloque * 2
   If Valor1 > Bloque2 Then
     Valor1 = Valor1 - Bloque2
     If Valor2 > Bloque2 Then
       Valor2 = Valor2 - Bloque2
     Else
       Acu = Acu + 1
       If Valor2 > Bloque Then Valor2 = Valor2 - Bloque
     End If
     GoTo Sort
   End If

   If Valor1 > Bloque Then
     Valor1 = Valor1 - Bloque
     If Valor2 > Bloque Then
       Valor2 = Valor2 - Bloque
     Else
       Acu = Acu + 1
     End If
   End If
Sort:
   If Valor2 > Valor1 Then
     Valor1 = Valor1 Xor Valor2
     Valor2 = Valor1 Xor Valor2
     Valor1 = Valor1 Xor Valor2
   End If
   Bloque = Bloque / 3
 Loop
 If Valor1 = Valor2 Then
 Else
   Acu = Acu + 1
 End If

 DimeQueHago = Acu


End Function


Lo dicho. Animaos y usad el coco un poco.

Saludos

EDIT:

¿que pasa?
¿no os interesa?
¿estáis deliberando?
¿me he pasado con el reto?
Igual no es tan fácil como pensé.
¿queréis que diga la solución?
¿queréis una pista?