Hola a todos!.
Hoy os dejo un pequeño post a modo respuesta a una consulta de este post: ALGORITMO DE ORDENACIÓN DE BURBUJA EN VBA Lo que me solicitan es poder pasar los datos ordenados de un rango de nuevo a la hoja, en el post los datos se pasaban a un msgbox.
Ya sé que existe la función Ordenar en Excel (de las nuevas funciones de matriz dinámica), pero lo que queremos conseguir es ordenar todo el rango seleccionado, no ordenar por fila o columna independiente.
Por ejemplo, tenemos estos rangos:

Y queremos ordenar todos los números de forma consecutiva con el mismo número de filas y columnas pero con los números ordenados. Es decir, así:

Efectivamente, todos los números del rango seleccionado se ordenar ocupando el mismo lugar consecutivamente. Lo he programado para que se ordene según esta estructura de datos, pero podéis realizar modificaciones a vuestro gusto vosotros mismos en el código, que por cierto os muestro a continuación:
Option Explicit
Sub Ordenar_Rango()
'Declaramos variables
Dim Rng As Range, celda As Variant
Dim Scadena As String, Valor As Variant, i, MiCadena As String
Dim miArray As Variant, Control As Boolean, BetaString As Double
Dim Valores As Variant, n As Long, Micolumna As Long
Dim Col As Long, Fil As Long, contador As Long
Dim Micelda As Long
'Seleccionamos rango con datos
Set Rng = Selection
Col = Rng.Columns.Count
Fil = Rng.Rows.Count
'Componemos cadena si la celda tiene datos y es un número
For Each celda In Rng
If celda <> vbNullString And IsNumeric(celda) Then
MiCadena = MiCadena & " " & celda.Value
End If
Next celda
Scadena = Trim(MiCadena)
'Si la selección está vacía, salimos del procedimiento
If Scadena = vbNullString Then Exit Sub
'Pasamos la cadena a un array
Valor = Split(Scadena, " ")
ReDim miArray(0 To UBound(Valor))
For i = 0 To UBound(Valor)
miArray(i) = CDbl(Valor(i))
Next i
'Ordenamos con algoritmo
Do
Control = True
For i = 0 To UBound(miArray) - 1
If miArray(i) > miArray(i + 1) Then
Control = False
BetaString = miArray(i)
miArray(i) = miArray(i + 1)
miArray(i + 1) = BetaString
End If
Next i
Loop While Not (Control)
'Pasamos los datos a la hoja
Valores = Split(Join(miArray, " "), " ")
contador = 1
Micelda = ActiveCell.Row
Micolumna = ActiveCell.Column
For n = LBound(Valores) To UBound(Valores)
If contador <= Fil Then
Cells(Micelda + contador - 1, Micolumna + Col + 1).Value = Valores(n)
contador = contador + 1
Else
n = n - 1
contador = 1
Micolumna = Micolumna + 1
End If
Next n
End Sub
Es un poco largo, pero siguiendo los comentarios y probando las diferentes partes de la rutina es sencillo comprender lo que estamos haciendo.
Obviamente lo realmente importante de este post no es el algoritmo de Burbuja, sino la parte en la que pasamos los datos del array a la hoja mediante un loop.
Este código se podría implementar como una UDF pero creo que es tanto o más interesante como un procedimiento Sub. También lo podremos hacer en otros lenguajes, pero hoy le toca a VBA 🙂
Puedes descargar aquí el archivo:
Y esto es todo, espero que os sea de utilidad!.
¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.
¡¡Muchas gracias!!
Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies