TRANSPONER RANGO EN HORIZONTAL SEGÚN NÚMERO DE ELEMENTOS REPETIDOS CON VBA

Hola a todos!

Espero que estéis bien!. El post de hoy es muy difícil describir su temática por el título pero estoy seguro que con la explicación lo entenderéis perfectamente.

Imaginad que sois empleados del censo de un ayuntamiento y necesitáis listar los hijos de hasta 18 años de la población para un estudio estadístico del INE. Los datos que extraéis del programa tienen el siguiente formato:

Por ejemplo, podemos ver que el núcleo familiar que se corresponde con el ID=1 tiene dos hijos con edad de 3 y 6 años, el ID=2 tres hijos con edades de 1, 7 y 17.

Lo que os piden es que enviéis la información con un formato específico. Cada ID en una fila donde en la primera columna irá el valor del ID, y en las siguientes columnas las edades de cada hijo.

Es decir, esto:

Estoy seguro que os habéis tenido que enfrentar a este tipo de formatos en alguna ocasión …, pues bien, nosotros no vamos a formatear la información a mano, lo haremos con una rutina que para eso esto es una web sobre el tratamiento de datos.

Os propongo el siguiente código en VBA:

Option Explicit
Sub TRANSPONER_RANGO()
'Declaramos variables
Dim Fin As Long, i As Long, j As Long, k As Long, n As Long
Dim MiCelda As String, Matriz As Variant, oDic As Object
Dim Cadena As String, Id As Variant, Fila As String, sCadena As String
Dim nText As Variant, Cont As Long, MiArray As Variant
    With Sheets("Hoja1")
    'Recorremos la primera columna y obtenemos únicos
        Fin = Application.CountA(.Range("A:A"))
        For i = 2 To Fin
            MiCelda = MiCelda & " " & .Cells(i, 1)
        Next i
        Matriz = Split(MiCelda, " ")
        Set oDic = CreateObject("scripting.dictionary")
        For j = 0 To UBound(Matriz)
            If Not oDic.Exists(Matriz(j)) Then oDic.Add Matriz(j), Matriz(j)
        Next j
        Cadena = Trim(Join(oDic.Keys, " "))
        Cont = 1
        'Por cada único buscamos datos en segunda columna
        For Each Id In Split(Cadena, " ")
            For k = 2 To Fin
                If "'" & .Cells(k, 1).Value = "'" & Id Then
                    Fila = Fila & ", " & .Cells(k, 2)
                End If
            Next k
            sCadena = Id & Fila
            nText = Split(Trim(sCadena), ", ")
            'Pasamos cada elemento a una columna
            ReDim MiArray(0 To UBound(nText))
            For n = 0 To UBound(nText)
                Sheets("Hoja2").Cells(Cont, n + 1) = nText(n)
            Next n
            Cont = Cont + 1
            sCadena = vbNullString
            Fila = vbNullString
        Next Id
        Sheets("Hoja2").Select
    End With
End Sub

Solo tenéis que leer las líneas comentadas y analizar detenidamente el código. Pero resumiendo, lo primero que hago es extraer los únicos de la primera columna:

'Recorremos la primera columna y obtenemos únicos
        Fin = Application.CountA(.Range("A:A"))
        For i = 2 To Fin
            MiCelda = MiCelda & " " & .Cells(i, 1)
        Next i
        Matriz = Split(MiCelda, " ")
        Set oDic = CreateObject("scripting.dictionary")
        For j = 0 To UBound(Matriz)
            If Not oDic.Exists(Matriz(j)) Then oDic.Add Matriz(j), Matriz(j)
        Next j
        Cadena = Trim(Join(oDic.Keys, " "))
        Cont = 1

A continuación, por cada uno de los registros inicio un For – next para componer una string con todas las edades (separadas por un delimitador (una coma). Y luego paso cada elemento de la cadena a la hoja 2. Primero el Id, y luego las edades de cada hijo:

'Por cada único buscamos datos en segunda columna
        For Each Id In Split(Cadena, " ")
            For k = 2 To Fin
                If "'" & .Cells(k, 1).Value = "'" & Id Then
                    Fila = Fila & ", " & .Cells(k, 2)
                End If
            Next k
            sCadena = Id & Fila
            nText = Split(Trim(sCadena), ", ")
            'Pasamos cada elemento a una columna
            ReDim MiArray(0 To UBound(nText))
            For n = 0 To UBound(nText)
                Sheets("Hoja2").Cells(Cont, n + 1) = nText(n)
            Next n
            Cont = Cont + 1
            sCadena = vbNullString
            Fila = vbNullString
        Next Id

Como podéis observar es una rutina bastante compleja para la necesidad que requerimos, pero es una de las distintas formas de hacerlo. Espero que os sea de utilidad!!

Os dejo el archivo por si lo queréis descargar: TRANSPONER RANGO EN HORIZONTAL SEGÚN NÚMERO DE ELEMENTOS REPETIDOS CON VBA

¿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