RE:Punto final
Publicado por
Devil (1 intervención) el 10/09/2007 17:21:45
Creo que la pregunta es clara. ¿Por qué tiene que dar explicaciones sobre lo que va a ordenar?. Ahí tienes el código para que ordenes lo que te plazca. Como siempre es mejorable y seguro que lo puedes adaptar a tus necesidades. Saludos a todos.
Sub Ordenar(ByRef Matríz As Collection, Ascendente As Boolean, BorraRepetidos As Boolean, Optional Campo As Byte)
'Los datos son una colección. Cada elemento de la colección puede ser un tipo de dato o una matríz de 1 dimensión _
Si queremos ordenar por el contenido de un elemento de la matríz (campo), debemos indicar su índice en Columna.
Dim MenorInd As Long, _
MayorInd As Long, _
Elemento(1 To 3) As Variant, _
EsMatriz(2 To 3) As Boolean, _
Aux As Variant, _
Destino As New Collection, _
DestInserta As Long, _
Contador As Long, _
Columna As Byte, _
ColAux As Byte, _
Iguales As Boolean
If Matríz.Count = 0 Then Exit Sub
DestInserta = 0
Do
'Cargamos los elementos de comparación de cualquier manera
MenorInd = 1
MayorInd = Matríz.Count
'Pasamos el contenido de los elementos seleccionados de la colección a elementos manejables
For Each Aux In Array(2, 3) 'Los select case no funcionan bien con objetos, por eso empleamos elementos variant
Select Case Aux
Case 2:
Elemento(1) = Matríz(MenorInd)
Case 3:
Elemento(1) = Matríz(MayorInd)
End Select
On Error Resume Next
'Tenemos que probar si es una matríz comprobando si se produce un error
Columna = UBound(Elemento(1))
If Err Then
'El elemento no es una matríz
Elemento(Aux) = Elemento(1) 'Pasamos el elemento auxiliar a un elemento de comparación correspondiente
Else
'El elemento es una matríz
Columna = Campo
If (UBound(Elemento(1)) < Columna) Or (LBound(Elemento(1)) > Columna) Then
'Si la columna no está en el rango consideramos sólo la primera
Columna = LBound(Elemento(1)) 'Modificamos la columna de ordenación si fuera necesario
End If
'Pasamos el contenido de la columna de ordenación del elemento auxiliar al elemento de comparación correspondiente
Select Case Aux
Case 2:
Elemento(Aux) = Matríz(MenorInd)(Columna)
Case 3:
Elemento(Aux) = Matríz(MayorInd)(Columna)
End Select
End If
Next
'Si estaban desordenados, los colocamos en orden
If Elemento(2) > Elemento(3) Then
Swap Elemento(2), Elemento(3)
Swap MenorInd, MayorInd
End If
'Recorremos la matríz buscando si los hay mayores y menores
For Contador = Matríz.Count - 1 To 2 Step -1 'Lo hacemos hacia atrás para poder borrar elementos repetidos _
sin problemas y sin tener que actualizar el final del contador
'Pasamos el contenido de los elementos seleccionados de la colección a elementos manejables
On Error Resume Next
'Tenemos que probar si es una matríz comprobando si se produce un error
Columna = UBound(Matríz(Contador))
If Err Then
'El elemento no es una matríz
Elemento(1) = Matríz(Contador)
Else
'El elemento es una matríz
Columna = Campo
If (UBound(Matríz(Contador)) < Columna) Or (LBound(Matríz(Contador)) > Columna) Then
'Si la columna no está en el rango consideramos sólo la primera
Columna = LBound(Matríz(Contador))
End If
Elemento(1) = Matríz(Contador)(Columna)
End If
Select Case Elemento(1)
Case Is < Elemento(2):
Elemento(2) = Elemento(1)
MenorInd = Contador
Case Is > Elemento(3):
Elemento(3) = Elemento(1)
MayorInd = Contador
End Select
Next
'Pasamos los elementos encontrados a la matríz de destino y los borramos del origen
If Destino.Count = 0 Then 'Si es el primero que salvamos
Destino.Add Matríz(MenorInd) 'Creo que cuando no hay elementos no puedo indicar la posición donde quiero que se guarden
Else
Destino.Add Matríz(MenorInd), , , DestInserta
End If
DestInserta = DestInserta + 1 'Apunta al elemento detrás del cual pondremos el siguiente menor y el siguiente mayor
If MayorInd <> MenorInd Then Destino.Add Matríz(MayorInd), , , DestInserta 'Guardamos después del menor
'Para evitar problemas a la hora de apuntar a los índices de los elementos a borrar, debe eliminarse primero el de mayor _
índice (con lo cual no cambia la posición de los elementos inferiores) y luego el de menor índice
Select Case MayorInd - MenorInd
Case Is > 0: 'El mayor está en una posición mas avanzada que el menor
'Borramos los elementos salvados de posición mas avanzada a menor posición
Matríz.Remove MayorInd
Matríz.Remove MenorInd
Case Is < 0: 'El mayor está en una posición menos avanzada que el menor
'Borramos los elementos salvados de posición mas avanzada a menor posición
Matríz.Remove MenorInd
Matríz.Remove MayorInd
Case 0: 'Coincidían. Borramos el elemento salvado
Matríz.Remove MenorInd
End Select
Loop Until Matríz.Count = 0
If Ascendente Then
'Copiamos Destino pues está Ascendenteado
Set Matríz = Destino
Else
Set Matríz = New Collection
Do While Destino.Count > 0 'Copiamos desde el último elemento para invertir el orden
Matríz.Add Destino(Destino.Count)
Destino.Remove Destino.Count
Loop
End If
Set Destino = Nothing
'Si hay que borrar los repetidos es muy fácil cuando están ordenados
If BorraRepetidos Then
'Borramos los repetidos recorriendo la matríz para comparar
'Los lazos for next no actualizan el valor final en cada iteración, por lo que los hacemos decrecientes
For Contador = Matríz.Count To 2 Step -1
'Pasamos el contenido de los elementos seleccionados de la colección a elementos manejables
For Each Aux In Array(2, 3) 'Los select case no funcionan bien con objetos iguales como Menor y Mayor
Select Case Aux
Case 2:
Elemento(1) = Matríz(Contador - 1) 'El menor
Case 3:
Elemento(1) = Matríz(Contador) 'El mayor
End Select
On Error Resume Next
'Tenemos que probar si es una matríz comprobando si se produce un error
Columna = UBound(Elemento(1))
If Err Then
'El elemento no es una matríz
EsMatriz(Aux) = False
Else
'El elemento es una matríz
EsMatriz(Aux) = True
End If
Next
'Comprobamos las distintas posibilidades de que los elementos que comparamos sean matrices o no
Select Case Abs(EsMatriz(2) * 2 + EsMatriz(3))
Case 0:
'Ninguno es una matriz. Los comparamos diréctamente
If Matríz(Contador - 1) = Matríz(Contador) Then
Iguales = True
Else
Iguales = False
End If
Case 1, 2:
'Son de distinto tipo
Iguales = False
Case 3:
'Los dos son una matriz
Iguales = True
ColAux = UBound(Matríz(Contador)) - LBound(Matríz(Contador))
If ColAux = UBound(Matríz(Contador - 1)) - LBound(Matríz(Contador - 1)) Then
'Si las dos tienen la misma cantidad de elementos
For Columna = 0 To ColAux
'Comparamos elemento por elemento hasta encontrar una diferencia
If Matríz(Contador)(LBound(Matríz(Contador)) + Columna) <> Matríz(Contador - 1)(LBound(Matríz(Contador - 1)) + Columna) Then
Iguales = False
Exit For
End If
Next
Else
'Si no tienen la misma cantidad de elementos no son iguales
Iguales = False
End If
End Select
If Iguales Then
Matríz.Remove (Contador)
End If
Next 'Matriz(contador)
End If
End Sub
Sub Swap(Item1 As Variant, Item2 As Variant)
Dim Temp As Variant
Temp = Item1
Item1 = Item2
Item2 = Temp
End Sub
