Pasar de tabla a Matriz en Excel vba.

En donde lo que me interesa son 4 columnas:

ID |  COMPONENTE | ORDEN | NIVEL

En donde para un ID existe más de un componente, y para un componente existe más de un orden (1, 2, 3... Etc ) y para el ID-COMPONENTE-ORDEN existe un NIVEL. Por lo que deseo llevar esta tabla a una matriz, en donde muestre 2 columnas ID | COMPONENTE | y una fila encabezado del ORDEN que iría del 1 en adelante. Y dentro de la matriz rellenar con el NIVEL (texto). Es como una tabla dinámica, pero no con valores, sino con texto. Tengo hecha esta matriz, pero con formula en donde cree una colmuna auxiliar para concatenar la busqueda, pero el archivo queda muy pesado cuando la base es muy grande y dificulta el procesamiento

Adjunto ejemplo para que quede más claro.

Base..

Como debería quedar la matriz.

.

4 respuestas

Respuesta
3

Te anexo la macro, se requieren 3 hojas, en la hoja1 van tus datos, en la hoja2 quedarán los resultados y la hoja3 es temporal, la requiere la macro.

Sub Tabla_Matriz()
'
' Por Dante Amor
'
    '
    Application.ScreenUpdating = False
    '
    Set h1 = Sheets("Hoja1")    'hoja con tabla
    Set h2 = Sheets("Hoja2")    'hoja con resultados
    Set h3 = Sheets("Hoja3")    'hoja temporal
    h2.Cells.Clear
    h3.Cells.Clear
    '
    h1.Columns("A:D").Copy h3.Range("A1")
    u = h3.Range("A" & Rows.Count).End(xlUp).Row
    With h3.Range("E2:E" & u)
        .FormulaR1C1 = "=RC[-4]&RC[-3]"
        .Value = .Value
    End With
    '
    h3.Columns("E").Copy h3.Range("F1")
    h3.Range("F1") = "Aux"
    h3.Range("F1:F" & u).RemoveDuplicates Columns:=1, Header:=xlYes
    '
    u3 = h3.Range("F" & Rows.Count).End(xlUp).Row
    With h3.Sort
        .SortFields.Clear
        .SortFields.Add Key:=h3.Range("F2:F" & u3), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange h3.Range("F1:F" & u3): .Header = xlYes: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
    '
    h1.Range("A1:B1").Copy h2.Range("A1")
    j = 2
    For i = 2 To u3
        Set r = h3.Columns("E")
        Set b = r.Find(h3.Cells(i, "F"), LookAt:=xlWhole)
        celda = b.Address
        Do
            'detalle
            existe = False
            uc = h2.Cells(1, Columns.Count).End(xlToLeft).Column
            For k = 3 To uc
                If h2.Cells(1, k) = h3.Cells(b.Row, "C") Then
                    col = k
                    existe = True
                    Exit For
                End If
            Next
            If existe = False Then col = uc + 1
            '
            h2.Cells(j, "A") = h3.Cells(b.Row, "A")
            h2.Cells(j, "B") = h3.Cells(b.Row, "B")
            h2.Cells(1, col) = h3.Cells(b.Row, "C")
            h2.Cells(j, col) = h3.Cells(b.Row, "D")
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
        j = j + 1
    Next
    h2.Select
    Application.ScreenUpdating = True
    MsgBox "Fin"
End Sub

.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Muchas gracias Dante!! se reflejó exactamente lo que buscaba. Seguiré trabajando en esta planilla, si tengo dudas espero poder contar con tu ayuda.

Respuesta
1

.

:)

Hola! Seba. Una forma de hacerlo sería con:

Sub ReDistribuir()
'------------------
'by Cacho Rodríguez
'------------------
Dim piv As Range, iKey$, C As Range, D As Range, Q&, i&, R%
Set piv = Range("A1")
Q = Range(piv, piv.End(xlDown)).Cells.Count
R = Application.Max(piv.Range("C1").Resize(Q))
piv.Resize(Q, 4).Sort _
  key1:=piv, order1:=xlAscending, _
  key2:=piv.Offset(, 1), order2:=xlAscending, _
  key3:=piv.Offset(, 2), order3:=xlAscending, Header:=xlYes
Set D = piv.Offset(, 5)
With D
  .Offset(, -1).Resize(Q, 4 + R).Clear
  .Resize(, 2) = Array("ID", "Componente")
  With .Offset(, 2)
    .Value = 1: .DataSeries Rowcol:=1, Type:=xlLinear, Step:=1, Stop:=R
  End With
End With
For Each C In piv.Offset(1).Resize(Q - 1)
  If UCase(C & "@" & C.Offset(, 1)) <> iKey Then
    iKey = C & "@" & C.Offset(, 1)
    Set D = D.Offset(1)
    D = C.Value: D.Offset(, 1) = C.Offset(, 1).Value
  End If
  D.Cells(1, 2 + C.Offset(, 2)) = C.Offset(, 3).Value
Next
piv.Offset(, 5).CurrentRegion.Columns.AutoFit
End Sub

¿Observas la línea: Set piv = Range("A1") ?...

Con ella estoy suponiendo que el encabezado de tu tabla de origen "ID" se encuentra en la celda A1. De no ser así: ¡Cámbialo!

¿Te sirve la idea?...
Saludos, Mario R.

:)

.

Muchas gracias Mario! es exactamente lo que buscaba, sin embargo no logro entender del todo el código, lo estudiaré para después ver algunas modificaciones y upgrade que necesite hacer a la planilla.

.

:)

No tienes más que re preguntar.

.

.

Respuesta

El resultado de la macro es este, es un poco larga por las instrucciones de formateo aunque eso no afecta la velocidad, si necesitas el archivo fuente solo colcoa un email y te lo envío

Sub ejecuta_macro()
preparar_tabla
armar_tabla
RELLENAR_TABLA_MATRIZ
FORMATEAR
End Sub
Rem ---------MACRO PARA ORDENAR LA TABLA Y CREAR UN CONCATENADO
Sub preparar_tabla()
Dim unicos As New Collection
Set datos = Range("a1").CurrentRegion
With datos
    Set datos = Rows(2).Resize(.Rows.Count - 1, .Columns.Count)
    .Sort _
    key1:=Range(.Columns(1).Address), order1:=xlAscending, _
    key2:=Range(.Columns(2).Address), order1:=xlAscending, _
    key3:=Range(.Columns(3).Address), order1:=xlAscending
    Set TABLA = .Columns(.Columns.Count + 1).Resize(.Rows.Count, 1)
    MATRIZ = TABLA
    For I = 1 To .Rows.Count
    ID = .Cells(I, 1): componente = .Cells(I, 2)
    texto = ID & "," & componente
    MATRIZ(I, 1) = texto
    Next I
    Range(TABLA.Address) = MATRIZ
    Set datos = .CurrentRegion
    .EntireColumn.AutoFit
    Set datos = .Rows(2).Resize(.Rows.Count - 1, .Columns.Count)
    datos.Name = "tabla_componentes"
End With
End Sub
Rem ---- MACRO PARA CREAR TABLA MATRIZ
Sub armar_tabla()
Dim unicos As New Collection
Set TABLA = Range("tabla_componentes")
With TABLA
    For I = 1 To .Rows.Count
        VALOR = .Cells(I, .Columns.Count)
        On Error Resume Next
        unicos.Add VALOR, CStr(VALOR)
        On Error GoTo 0
    Next I
    Set TABLA2 = .Columns(.Columns.Count + 3).Resize(unicos.Count, 3)
    MATRIZ = TABLA2
    For J = 1 To unicos.Count
        VALOR = unicos.Item(J):    separa = Split(VALOR, ",")
        MATRIZ(J, 1) = VALOR
        For k = 0 To UBound(separa)
            MATRIZ(J, k + 2) = separa(k)
        Next k
    Next J
End With
With TABLA2
    Range(.Address) = MATRIZ
    .EntireColumn.AutoFit
    .Name = "TABLA_MATRIZ"
End With
End Sub
Rem --- MACRO PARA LLENAR LA TABLA MATRIZ
Sub RELLENAR_TABLA_MATRIZ()
TITULOS = Array("ID", "COMPONENTES")
Set MATRIZ = Range("TABLA_MATRIZ")
Set TABLA = Range("tabla_componentes")
Set FUNCION = WorksheetFunction
With TABLA
    MAXIMO = FUNCION.Max(.Columns(3))
    With MATRIZ
        Set TABLA2 = .Columns(.Columns.Count + 1).Resize(.Rows.Count, MAXIMO)
    For I = 1 To .Rows.Count
        VALOR = .Cells(I, 1)
        CUENTA = FUNCION.CountIf(TABLA.Columns(TABLA.Columns.Count), VALOR)
        FILA = FUNCION.Match(VALOR, TABLA.Columns(TABLA.Columns.Count), 0)
        Set TABLA3 = TABLA.Cells(FILA, 4).Resize(CUENTA, 1)
        TABLA2.Rows(I).Resize(1, CUENTA).Value = FUNCION.Transpose(TABLA3.Value)
    Next I
    .Columns(1).Clear
    Set MATRIZ = .Columns(2).CurrentRegion
    .Rows(0).Resize(1, 2) = TITULOS
    .Cells(0, 3) = 1
    .Cells(0, 4).Resize(1, MAXIMO - 1).Formula = "=" & .Cells(0, 3).Address(False, False) & "+1"
    .Cells(0, 3).Resize(1, MAXIMO).Interior.ColorIndex = 22
    .EntireColumn.AutoFit
    Set MATRIZ = .CurrentRegion
    .Resize(.Rows.Count, 2).Interior.ColorIndex = 44
    .Rows(1).Font.Bold = True
    .Cells(2, 3).Resize(.Rows.Count - 1, .Columns.Count - 2).Select
     End With
     .Columns(.Columns.Count).Clear
End With
End Sub
Sub FORMATEAR()
    Set selecion = Selection
    With selecion
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
    With .Borders(xlEdgeLeft):
        .LineStyle = xlContinuous: .Weight = xlThin
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous: .Weight = xlThin
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous:  .Weight = xlThin
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous:   .Weight = xlThin
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous:    .Weight = xlThin
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous:     .Weight = xlThin
    End With
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous:     .Weight = xlMedium
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous:     .Weight = xlMedium
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous:     .Weight = xlMedium
    End With
    With .Borders(xlEdgeRight):
        .LineStyle = xlContinuous:      .Weight = xlMedium
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous:      .Weight = xlThin
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous:      .Weight = xlThin
    End With
End With
End Sub
Respuesta

Tienes una alternativa adicional... en Excel 2016 (si es que dispones de él)... completamente diferente... demora en implementar aproximadamente 3-4 minutos y no usa ninguna macro.

Te lo planteo por ti se sirve...

1) Haz clic en tu base de datos:

En la cinta Datos pones Insertar/Tabla

En lo que salga pon aceptar... ya tienes una tabla de Excel

2) Ve a la cinta Datos y la zona Obtener y transformar, elige el icono "Desde tabla"... entrarás a la interfaz de Query (en Excel2016 se llama obtener y transformar)

3) Hacia la derecha aparecerá un lista que dice "Pasos aplicados"... haz clic en la X que hay al lado de "Tipo cambiado" (el segundo paso), esto es para que la primera columna no se convierta a números... Query de buena intención reconoce números... e intenta arreglarlos por ti... si no te apareció este paso, ignóralo.

4) Presionando la tecla Shift haz clic en ID y Nivel (1ra y 4ta columna)... te las marcará... luego clic en el triangulo negro que hay (tipo combo box) del icono "Quitar columnas", alli elige "Quitar otras columnas"... Te quedarán visibles solo la cuatro columnas que te interesan

5) Haz clic en el encabezado Orden para que te seleccione esa columna.

6) Clic en la cinta Transformar, y alli en el ícono de "Columna dinámica"

7) En la interfaz que aparezca, cambia en Columna de Valores: "ID" por "NIVEL"

8) Haz clic en el triangulo que aparece al lado de Opciones Avanzadas y en el combobox que aparezca de Función de valor agregado cambia "Recuento (todo)" por "No agregar".

9) Pon aceptar... veras tu tabla ya hecha... cierra la interfaz con la X como si estuvieras cerrando el Excel... Elige "Mantener"... Excel crerá una tabla con los resultados... Cuando quieras actualizar tu macro simplemente posiciónate en esta tabla y presiona Alt+F5

Listo... Query al rescate!... y lo hiciste tu mismo!

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas