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
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.
.
:)
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.
.
.
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
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!