Tabla cartesiana en Excel

Francisco 06-04-09
Programacin : Ofimtica

Se trata de una funcin que crea una tabla de

referencias cruzadas. El resultado final es, en
apariencia, como una tabla dinmica. Todo el proceso est
automatizado utilizando el Visual Basic de las macros de Excel.
Mediante este cdigo se podra copiar el resultado de una consulta de
agrupacin que al menos tuviese dos campos de agrupacin y cruzar
la agrupacin por filas y columnas.

Formato de entrada
La entrada es una tabla colocada en una hoja de clculo cuyas columnas estn
dispuestas en las siguientes posiciones:

Las primeras columnas o campos servirn para agrupar por columnas.

Las siguientes columnas agruparn por filas.

Las ltimas columnas contienen los datos.

Anlisis visual
1. Tabla de origen Los datos de partida
2. Filas de la tabla destino Proceso paso a paso sobre las filas
3. Columnas de la tabla destino Proceso paso a paso sobre las columnas
4. Tabla destino Proceso para colocar los datos

Secuencia animada del proceso desde el inicio hasta el final

Funcin principal: CrearTablaCartesiana

Sintaxis:
Public Function CrearTablaCartesiana( _
ByVal origen As Range, ByVal destino As Range, _
ByVal colsColumnas As Integer, _
ByVal colsFilas As Integer, _
ByVal colsDatos As Integer, _
Optional ByVal opcionCombinar As Boolean = True, _
Optional ByVal opcionTotal As Boolean = True, _
Optional ByVal opcionFormatear As Boolean = True, _
Optional ByVal opcionRatios As Boolean = True, _
Optional ByVal opcionAjustar As Boolean = True, _
Optional ByVal opcionFijar As Boolean = True _
) As Boolean

Parmetros de la funcin
Parmetro

Descripcin

origen

Una celda dentro de la tabla con los datos

destino

La celda superior izquierda de la tabla resultado

colsColumnas

N de columnas de la tabla origen destinadas a ser encabezados de

columnas de la tabla destino

colsFilas

N de columnas de la tabla origen destinadas a ser encabezados de

filas en la tabla destino

colsDatos

N de columnas de la tabla origen destinadas a ser datos en la tabla

destino

opcionCombinar

Combina las celdas iguales de los encabezados de filas o columnas

opcionTotal

Aade una fila inferior con el total de las columnas de datos

opcionFormatea
r

Colorea y aplica formato a las tablas

opcionAjustar

Ajusta automticamente el ancho de las columnas

Parmetro
opcionFijar

Descripcin
Fija los titulos de la hoja de clculo

Ejemplos de uso
Cdigo

Ejemplo

Call CrearTablaCartesiana( _
ActiveSheet.Range("B2"), _
ActiveSheet.Range("B26"), _
2, 2, 2)

Pantallazo 1-1

Call CrearTablaCartesiana( _
ActiveSheet.Range("B2"), _
ActiveSheet.Range("B26"), _
1, 3, 2)

Pantallazo 1-2

Call CrearTablaCartesiana( _
ActiveSheet.Range("B2"), _
ActiveSheet.Range("K2"), _
1, 3, 4)

Pantallazo 2-1

Call CrearTablaCartesiana( _
ActiveSheet.Range("B2"), _
ActiveSheet.Range("K2"), _
2, 2, 4)

Pantallazo 2-2

Frmulas
Se pueden agregar algunas frmulas escritas de una forma simplificada que luego
se traducen a frmulas autnticas de la hoja de clculo. Ejemplos:

'=Precio*Cantidad

Significa que multiplique la celda de la columna Precio por la

celda de la columna Cantidad que se encuentren en la misma fila
que la frmula.

'=Importe/
$Importe

Significa que divida la celda de la columna Importe en la misma

fila que la frmula por el total de Importe situado en la fila de
totales.

Las frmulas se han de introducir cmo si fuesen texto aadiendo un apstrofe al

principio. Slo se pueden introducir este tipo de frmulas en las columnas
correspondientes a datos y no a agrupaciones.

Cdigo fuente

moduloColor

Constantes con los ndices de colores en Excel

o COLOR_NEGRO, COLOR_BLANCO, etc.

Funciones:
o ColorearFilas Colorea cebrando (una fila s y otra
no) las filas desde y hasta las columnas indicadas.
Ignora la primera fila porque se la considera de
ttulos.
o Colorear Colorea el fondo de los rangos indicados
con los colores indicados.
o CebrarFilas Colorea las filas pares del rango
indicado.
o Cuadricular Bordea las celdas del rango indicado.
o ColorearColumnas Colorea de N en N columnas con la lista de
colores indicados.
o ColorColumnas, ColorFilas, ColorDatos, ColorTitulos,
ColorFormula Color definido para las filas impares y pares de la
tabla destino.

moduloCartesiano

Pblico
o CrearTablaCartesiana Funcin principal
TC

TF

TD

c1

f1

c1

f2

TC

c1

c2

d1

TF

TD

TD

d2

f1

d1

d3

c2

f1

d3

c2

f2

d4

f2

d2

Privado
o CopiarDatosCartesianos Copia en las posiciones correctas los
datos de la tabla origen en la tabla destino
o Formular Calcula las frmulas pendientes. Convierte en frmulas
reales las frmulas simplificadas.
o Copiar Copia el rango origen en el destino.
o OrdenarFilas Ordena las filas tomando como criterio de
ordenacin las columnas de la primera hasta la ltima.
C1
B3
A2
B1

A2
B1
B3
C1

o EliminarFilasDuplicadasConsecutivas Borra las filas consecutivos

cuyos contenidos sean los mismos.
A
A
A
B
B

A
B
-

o CompactarFilas Sube las filas inferiores aprovechando los huecos

de las filas vacas.
A
B
-

A
B

d4

o DuplicarFilas Duplica cada fila el nmero de veces indicado

A
B
C

A
A
B
B
C
C

A
B

o FormatearGrupos Combina las celdas consecutivas con el mismo

valor que se encuentren dentro de la misma columna o bien dentro
de la misma fila, segn est indicado en el parmetro tipo.
AAB B B
VWXYZ

---A--- --B-VWXYZ

o BordearGrupos Borda las columnas de arriba a abajo o las filas

de izquierda a derecha segn los datos de la primera fila o de la
primera columna.
---A--- --B-VWXYZ

| A | B |
|V W X | Y Z |

o Transponer Copia el rango cambiando filas por columnas y

viceversa.
A
B
C

ABC

o Borrar Elimina el contenido de las celdas.

o Rellenar Copia N veces el rango origen en el rango destino.
AB

A B A B A B A B ...

o RellenarFormato Copia el formato de origen en el destino

o Totalizar Crea una fila con el total de cada columna

A
A
A
B
B
B

o RangosIguales Indica si los contenidos de los dos rangos coinciden

Descarga
Todo el cdigo y ejemplos de uso

tabla_cartesiana_2010-06-03.xls.7z

Attribute VB_Name = "moduloCartesiano_2009_12_04"

Option Explicit
'Mdulo Cartesiano
' Entrada:
'
Una tabla de agrupacin. Las columnas indican niveles de agrupacin
en detalle
'
creciente. Las ltimas columnas son los datos
'
' Salida:
'
Una nueva tabla dnde algunas de las primeras columnas de agrupacin
'
se han dispuesto en forma horizontal. Semejante a un producto
cartesiano
'
o semejante a una tabla dinmica
'
'2009-IV-1 versin 1.0 <fco@proinf.net>
'2009-IV-16 version 1.1 '2009-IV-21 versin 1.2 '2009-V-7
versin 1.3 - Poder quitar ttulos y agregar grficos
'2009-V-12 versin 1.4 - Mejorar grficos y totales
'2009-V-14 versin 1.5 - Tabla dinmica y grfico dinmico
'2009-V-21 versin 1.6 - Parmetro patronFormatos
'2009-X-5
version 1.7 - Control de errores al crear grfico

'2009-XII-4 versin 1.8 - Controlar en Transponer cuando hay 256

columnas
'-----------------------------------------------' CONSTANTES
'-----------------------------------------------Const SEPARADOR_LISTA = ";"
'-----------------------------------------------' FUNCIONES DE PRUEBA
'-----------------------------------------------Public Sub PruebaModuloCartesiano()
'2009-IV-3
'Dim prueba As Worksheet
'Dim rango As Range, rango2 As Range
'Set prueba = Sheets("pruebas")
'Set rango = prueba.Range("m3").CurrentRegion
'Set rango2 = prueba.Range("q3").CurrentRegion
'PRUEBAS INDIVIDUALES
'Call OrdenarFilas(rango)
'Call EliminarFilasDuplicadasConsecutivas(rango)
'Call CompactarFilas(rango)
'Call CombinarGrupos(rango, "COLUMNA")
'Call Transponer(rango, rango2)
'Call CombinarGrupos(rango2, "FILA")
'Call Rellenar(prueba.Range("q6:r6"), prueba.Range("q6:ab6"))
'Call BordearGrupos(Sheets("destino").Range("B5:I10"), "FILA")
'Call BordearGrupos(Sheets("destino").Range("D2:I10"), "COLUMNA")
'Call CrearTablaCartesiana( _
Worksheets("Hoja1").Range("B2"), _
Worksheets("Hoja1").Range("B26"), _
2, 2, 2, _
opcionFijar:=False, _
opcionAjustar:=False)
'Prueba GENERAL
Call BorrarDatosHoja("destino")
Call BorrarHojas("grafico*")
Call BorrarHojas("*dinamica")
Call CrearTablaCartesiana( _
Worksheets("origen").Range("B2"), _
Worksheets("destino").Range("B2"), _
2, 2, 4, _
opcionFijar:=False, _
opcionTitulos:=True, _
opcionGraficos:=True, _
patronGraficos:="C-B-", _
patronTotales:="SASA")
Call CrearTablaDinamica( _
Worksheets("origen").Range("B2").CurrentRegion, _

2, 2, 4)
End Sub
'-----------------------------------------------' FUNCION PRINCIPAL
'-----------------------------------------------Public Function CrearTablaCartesiana( _
ByVal origen As Range, ByVal destino As Range, _
ByVal colsColumnas As Integer, ByVal colsFilas As Integer, ByVal
colsDatos As Integer, _
Optional ByVal opcionTotales As Boolean = True, _
Optional ByVal opcionGraficos As Boolean = False, _
Optional ByVal opcionCombinar As Boolean = True, _
Optional ByVal opcionFormatear As Boolean = True, _
Optional ByVal opcionRatios As Boolean = True, _
Optional ByVal opcionAjustar As Boolean = True, _
Optional ByVal opcionFijar As Boolean = True, _
Optional ByVal opcionTitulos As Boolean = True, _
Optional ByVal patronTotales As Variant = "S", _
Optional ByVal patronGraficos As Variant = "C", _
Optional ByVal patronFormatos As Variant = "" _
) As Boolean
'Funcin principal
'
'
Origen
Destino
'
'
TC TF TD
TC c1 c2
'
c1 f1 d1
TF TD TD
'
c1 f2 d2
-->
f1 d1 d3
'
c2 f1 d3
f2 d2 d4
'
c4 f2 d4
'
'
' Patrn totales:
'
Ej: "S-A-"
'
Ej: "=SUM(<>);;=AVERAGE(<>);=RC[-1]/RC[-2]"
'
Abreviaturas: S=suma, A=promedio, -=nada
'
' Patrn grficos:
'
Ej: "C-S-"
'
Ej: "C;;S;"
'
Abreviaturas: C=columnas,S=columnas
apiladas,A=rea,L=lnea,B=barras,P=tarta
'
' Patrn formatos:
'
Ej: "-H-"
oculta la segunda columna de datos
'
Ej: ";#.##0" formatea la segunda columna
'
'2009-IV-1 <fco@proinf.net>
'2009-IV-5
'2009-IV-23 Opcin ttulos y opcin grficos
'2009-V-12 Patrn de totales y grficos
'Comprobacin inicial

If colsColumnas <= 0 Or colsFilas <= 0 Or colsDatos <= 0 Then '2009V-19

Exit Function
End If

'Inicializacin
Application.ScreenUpdating = False 'TRUE=para depurar, FALSE=versin
final
'Declaracin de variables
Dim origenTitulosColumnas As Range, destinoTitulosColumnas As Range
Dim origenTitulosFilas As Range, destinoTitulosFilas As Range
Dim origenTitulosDatos As Range, destinoTitulosDatos As Range
Dim origenColumnas As Range, destinoColumnas As Range
Dim origenFilas As Range, destinoFilas As Range
Dim origenDatos As Range, destinoDatos As Range
Dim destinoTitulosTotal As Range, destinoTotal As Range
Dim rangoTrabajo As Range
Dim filasOrigen As Integer
Dim filas As Integer, columnas As Integer, rango As Range
'Corregir parmetros
Set origen = origen.CurrentRegion
Set destino = destino.Range("A1")
'Averiguar rangos
filasOrigen = origen.Rows.Count
Set origenColumnas = origen.Offset(1, 0).Resize(filasOrigen - 1,
colsColumnas)
Set origenFilas = origen.Offset(1, colsColumnas).Resize(filasOrigen 1, colsFilas)
Set origenDatos = origen.Offset(1, colsColumnas +
colsFilas).Resize(filasOrigen - 1, colsDatos)
'''
Set origenTitulosColumnas = origenColumnas.Offset(-1, 0).Resize(1)
Set origenTitulosFilas = origenFilas.Offset(-1, 0).Resize(1)
Set origenTitulosDatos = origenDatos.Offset(-1, 0).Resize(1)
Set
Set
Set
'''
Set
Set
Set

destinoColumnas = destino.Offset(0, colsFilas)

destinoFilas = destino.Offset(colsColumnas + 1, 0)
destinoDatos = destino.Offset(colsColumnas + 1, colsFilas)
destinoTitulosColumnas = destinoColumnas.Offset(, -1)
destinoTitulosFilas = destinoFilas.Offset(-1)
destinoTitulosDatos = destinoDatos.Offset(-1)

'Comprobacin visual
If opcionFormatear Then

Colorear ColorColumnas(COLOR_IMPAR), origenColumnas,

destinoColumnas
Colorear ColorFilas(COLOR_IMPAR), origenFilas, destinoFilas
Colorear ColorDatos(COLOR_IMPAR), origenDatos, destinoDatos
If opcionTitulos Then
Colorear colorTitulos, origenTitulosColumnas,
origenTitulosFilas, origenTitulosDatos
Colorear colorTitulos, destinoTitulosColumnas,
destinoTitulosFilas, destinoTitulosDatos
End If
End If
'Pasar las COLUMNAS
Call Copiar(origenColumnas, destinoDatos)
Set rangoTrabajo = destinoDatos.CurrentRegion
Call OrdenarFilas(rangoTrabajo)
Call EliminarFilasDuplicadasConsecutivas(rangoTrabajo)
Call CompactarFilas(rangoTrabajo)
Call DuplicarFilas(rangoTrabajo, veces:=colsDatos)
Set rangoTrabajo = rangoTrabajo.CurrentRegion
If Not Transponer(rangoTrabajo, destinoColumnas) Then Exit Function
Set destinoColumnas = destinoColumnas.CurrentRegion
Call Borrar(rangoTrabajo)
If opcionFormatear Then
Colorear ColorColumnas(COLOR_IMPAR), destinoColumnas
destinoColumnas.Borders.LineStyle = xlNone
End If
'Pasar las FILAS
Call Copiar(origenFilas, destinoFilas)
Set rangoTrabajo = destinoFilas.CurrentRegion
Call OrdenarFilas(rangoTrabajo)
Call EliminarFilasDuplicadasConsecutivas(rangoTrabajo)
Call CompactarFilas(rangoTrabajo)
Set destinoFilas = destinoFilas.CurrentRegion
If opcionFormatear Then
Colorear ColorFilas(COLOR_IMPAR), destinoFilas
destinoFilas.Borders.LineStyle = xlNone
End If
'Pasar los DATOS
Set destinoDatos = destinoDatos.Resize(destinoFilas.Rows.Count,
destinoColumnas.Columns.Count)
'Titulos
Call Copiar(origenTitulosDatos, destinoTitulosDatos)
Set destinoTitulosDatos = destinoTitulosDatos.Resize(,
destinoColumnas.Columns.Count)
Call Rellenar(destinoTitulosDatos.Resize(, colsDatos),
destinoTitulosDatos)
Call CopiarDatosCartesianos( _
origenColumnas, destinoColumnas, _
origenFilas, destinoFilas, _
origenDatos, destinoDatos)

Call Formular(destinoDatos, destinoTitulosDatos.Resize(, colsDatos))

'2009-V-21
Call RellenarFormato(origenDatos.Resize(1), destinoDatos) '2009-XI-30
patronFormatos = PatronEnArray(patronFormatos, colsDatos)
Call FormatearDatos(destinoDatos, patronFormatos)
'Comprobacin visual
If opcionFormatear Then
Colorear ColorDatos(COLOR_IMPAR), destinoDatos, colorTitulos,
destinoTitulosDatos
Call ColorearColumnas(destinoDatos, colsDatos, Array(COLOR_MENTA,
COLOR_CELESTE, COLOR_VAINILLA, COLOR_CANELA, COLOR_ROSA, COLOR_LAVANDA,
COLOR_CIELO))
Call CebrarFilas(destinoDatos, ColorDatos)
Call Cuadricular(destinoDatos)
End If
'Fila de totales
If opcionTotales Then
patronTotales = PatronEnArray(patronTotales, colsDatos)
Set destinoTotal =
destinoDatos.Offset(destinoDatos.Rows.Count).Resize(1)
Call Totalizar(destinoDatos, destinoTotal, patronTotales)
If opcionFormatear Then
Colorear colorFormula, destinoTotal
End If
End If
'Grficos
If opcionGraficos Then
opcionCombinar = False
patronGraficos = PatronEnArray(patronGraficos, colsDatos)
'Por cada columna de datos crear una hoja de grfico
'''filas = destinoFilas.Rows.Count + colsColumnas + 1
Call CrearGraficos( _
destinoDatos, _
destinoFilas.Columns.Count, _
destinoColumnas.Rows.Count, _
colsDatos, _
patronGraficos)
End If
'Ttulos
If opcionTitulos Then
'Ttulos de columnas
Set destinoTitulosColumnas =
destinoTitulosColumnas.Resize(colsColumnas)
Call Transponer(origenTitulosColumnas, destinoTitulosColumnas)
If opcionFormatear Then
Colorear colorTitulos, colorTitulos, destinoTitulosColumnas
End If

'Ttulos de fila
Call Copiar(origenTitulosFilas, destinoTitulosFilas)
Set destinoTitulosFilas = destinoTitulosFilas.Resize(, colsFilas)
If opcionFormatear Then
Colorear colorTitulos, destinoTitulosFilas
End If
'Ttulos de Totales
Set destinoTitulosTotal = destinoTotal.Offset(, -1).Resize(, 1)
destinoTitulosTotal.Value = "Total"
If opcionFormatear Then
Colorear colorTitulos, destinoTitulosTotal
destinoTotal.Font.Size = 8
destinoTitulosTotal.Font.Size = 8:
destinoTitulosTotal.HorizontalAlignment = xlRight
End If
End If

'Acabar de formatear
If opcionFormatear Then
If opcionTitulos Then
destinoTitulosColumnas.Font.Size = 8:
destinoTitulosColumnas.HorizontalAlignment = xlRight
destinoTitulosFilas.Font.Size = 8:
destinoTitulosFilas.HorizontalAlignment = xlCenter
End If
destinoTitulosDatos.Font.Size = 8:
destinoTitulosDatos.HorizontalAlignment = xlCenter
Call CebrarFilas(origenColumnas, ColorColumnas)
Call CebrarFilas(origenFilas, ColorFilas)
Call CebrarFilas(origenDatos, ColorDatos)
Call CombinarGrupos(destinoColumnas, "FILA", ColorColumnas,
opcionCombinar)
Call CombinarGrupos(destinoFilas, "COLUMNA", ColorFilas,
opcionCombinar)
filas = destinoColumnas.Rows.Count + 1
columnas = destinoFilas.Columns.Count + 0
If opcionCombinar Then
If colsColumnas > 1 Or colsDatos > 1 Then
Call BordearGruposCombinados(destinoDatos.Offset(filas).Resize(destinoDatos.Rows.Count + filas), "COLUMNA")
End If
If colsFilas > 1 Then
Call BordearGruposCombinados(destinoDatos.Offset(,
-columnas).Resize(, destinoDatos.Columns.Count + columnas), "FILA")
End If
Else
If colsColumnas > 1 Or colsDatos > 1 Then
Call BordearGrupos(destinoDatos.Offset(filas).Resize(destinoDatos.Rows.Count + filas), "COLUMNA")
End If
If colsFilas > 1 Then

Call BordearGrupos(destinoDatos.Offset(,
-columnas).Resize(, destinoDatos.Columns.Count + columnas), "FILA")
End If
End If
With destinoTitulosDatos.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = COLOR_GRIS
End With
End If
If opcionAjustar Then
Call AutoajustarColumnas(Union(destinoFilas, destinoDatos))
End If
'Fijar ttulos
If opcionFijar Then
destinoDatos.Worksheet.Activate
destinoDatos.Cells(1).Activate
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
End If
'Crear nombres de rango 2009-V-21
'destinoDatos.Name = "datos"
'destinoTotal.Name = "total"
'''etc.
'Finalizacin
Application.ScreenUpdating = True
CrearTablaCartesiana = True
End Function
Public Function CrearTablaDinamica( _
source As Range, _
colsColumnas As Integer, colsFilas As Integer, colsDatos As Integer,
_
Optional ByVal nombreTabla As String = "tabla_dinamica", _
Optional ByVal nombreGrafica As String = "grafica_dinamica" _
) As String
'Crea una tabla dinmica y un grfico dinmico
'Entrada:
'
Una tabla de agrupacin. Las columnas indican niveles de agrupacin
en detalle
'
creciente. Las ltimas columnas son los datos
'
'2009-V-14 <fco@proinf.net>
'Cdigo
Dim cache As PivotCache
Dim pivot As PivotTable

Dim
Dim
Dim
Dim
Dim
Dim
Dim

Chart As Chart
etiquetas As Range
celda As Range
contador As Integer
nombre As String
etiqueta As String
orientacion As Integer

nombreTabla = NuevoNombreHoja(nombreTabla)
With source.Worksheet
.Visible = xlSheetVisible
.Select
End With
Set cache = ActiveWorkbook.PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:=source)
Set pivot = cache.CreatePivotTable( _
TableDestination:="", _
TableName:=nombreTabla, _
DefaultVersion:=xlPivotTableVersion10)
ActiveSheet.Name = nombreTabla
contador = 0
Set etiquetas = source.Resize(1)
orientacion = xlColumnField
For Each celda In etiquetas.Cells
nombre = celda.Value
etiqueta = nombre & " "
contador = contador + 1
Select Case orientacion
Case xlColumnField
pivot.PivotFields(nombre).Orientation = orientacion
If contador >= colsColumnas Then
contador = 0
orientacion = xlRowField
End If
Case xlRowField
pivot.PivotFields(nombre).Orientation = orientacion
If contador >= colsFilas Then
contador = 0
orientacion = xlDataField
End If
Case xlDataField
pivot.AddDataField pivot.PivotFields(nombre), etiqueta,
xlSum
pivot.PivotFields(etiqueta).NumberFormat =
celda.Offset(1).NumberFormat '"#,##0.00"
If contador >= colsDatos Then
Exit For
End If
End Select
Next

If pivot.DataFields.Count > 1 Then

pivot.DataPivotField.Orientation = xlColumnField
End If
Set Chart = Charts.Add(After:=ActiveSheet)
Chart.SetSourceData source:=Worksheets(nombreTabla).Range("A1")
Chart.Location Where:=xlLocationAsNewSheet
Chart.Name = NuevoNombreHoja(nombreGrafica)
CrearTablaDinamica = nombreTabla
End Function
'-----------------------------------------------' FUNCIONES AUXILIARES DE LA FUNCIN PRINCIPAL
'-----------------------------------------------Private Function CopiarDatosCartesianos( _
origenColumnas As Range, destinoColumnas As Range, _
origenFilas As Range, destinoFilas As Range, _
origenDatos As Range, destinoDatos As Range _
) As Boolean
'Copia en las posiciones correctas los datos de la tabla origen en la
tabla destino
'2009-IV-5
Dim
Dim
Dim
Dim
Dim
Dim
Dim

origCol As Range, origFil As Range, origDat As Range

destCol As Range, destFil As Range, destDat As Range
dest As Range
cuenta As Integer, maxCuenta As Integer
numFils As Integer, indFil As Integer, fil As Integer
numCols As Integer, indCol As Integer, col As Integer
numDatos As Integer

numDatos = origenDatos.Columns.Count
Set origCol = origenColumnas.Resize(1)
Set origFil = origenFilas.Resize(1)
Set origDat = origenDatos.Resize(1)
Set destCol = destinoColumnas.Resize(, 1)
Set destFil = destinoFilas.Resize(1)
Set destDat = destinoDatos.Resize(1, numDatos)
indCol = 1: numCols = destinoColumnas.Columns.Count \ numDatos
indFil = 1: numFils = destinoFilas.Rows.Count
maxCuenta = origenDatos.Rows.Count
For cuenta = 1 To maxCuenta
'Buscar la columna desde dnde nos quedamos la vez anterior...
' El bucle for sirve para controlar que no entremos en un bucle

infinito

For col = 1 To numCols

If RangosIguales(origCol, destCol) Then

Exit For
End If
If indCol >= numCols Then
indCol = 1
Set destCol = destinoColumnas.Resize(, 1)
Else
indCol = indCol + 1
Set destCol = destCol.Offset(, numDatos)
End If
Next
'Buscar la fila desde dnde nos quedamos la vez anterior...
' El bucle for sirve para controlar que no entremos en un bucle
infinito

For fil = 1 To numFils

If RangosIguales(origFil, destFil) Then
Exit For
End If
If indFil >= numFils Then
indFil = 1
Set destFil = destinoFilas.Resize(1)
Else
indFil = indFil + 1
Set destFil = destFil.Offset(1)
End If
Next
Set dest = destDat.Offset(indFil - 1, (indCol - 1) * numDatos)
'''dest.Select
Call Copiar(origDat, dest)
Set origCol = origCol.Offset(1)
Set origFil = origFil.Offset(1)
Set origDat = origDat.Offset(1)

Next

End Function
Private Function Formular( _
datos As Range, _
titulos As Range _
) As Boolean
'Calcula las frmulas pendientes
'Convierte en frmulas reales las frmulas simplificadas.
'Ej: '=Precio/$Precio
significa el precio dividido por el total de
precio
'
'=Precio*Cantidad significa el precio por la cantidad
'2009-IV-5 <fco@proinf.net>
Dim
Dim
Dim
Dim
Dim
Dim

columna As Range, celda As Range

colDatos As Integer, numColsDatos As Integer
colTitulo As Integer, numColsTitulos As Integer
colFormula As Integer
colRef As Integer, filTotal As Integer
titulo As String

Dim crudo As String, formula As String

Dim ref As String, refTotal As String
colFormula = 1
filTotal = datos.Offset(datos.Rows.Count).Cells(1).Row
numColsDatos = datos.Columns.Count
numColsTitulos = titulos.Columns.Count
Set columna = datos.Resize(, 1)
For colDatos = 1 To numColsDatos
For Each celda In columna
If Left(celda.Value, 1) = "=" Then
If celda.Value <> crudo Then
crudo = celda.Value
formula = crudo
For colTitulo = 1 To numColsTitulos
titulo = titulos.Cells(colTitulo).Value
colRef = colTitulo - colFormula
ref = "RC[" & colRef & "]"
refTotal = "R" & filTotal & "C[" & colRef & "]"
formula = Replace(formula, "$" & titulo,
refTotal)
formula = Replace(formula, titulo, ref)
Next
End If
celda.FormulaR1C1 = formula
With celda.Font
.ColorIndex = COLOR_CENIZA
.Size = 8
End With
End If
Next
Set columna = columna.Offset(, 1)
colFormula = colFormula + 1
If colFormula > numColsTitulos Then
colFormula = 1
End If
Next
End Function
Private Function FormatearDatos( _
datos As Range, _
listaFormatos As Variant _
) As Boolean
'Formatea las columnas de datos y oculta columnas
'2009-V-21 <fco@proinf.net>
Dim
Dim
Dim
Dim
Dim
Dim

DatosConTotales As Range
columna As Range
indice As Integer
cuenta As Integer
fila As Integer
formato As String

Set DatosConTotales = datos.Resize(datos.Rows.Count + 1)

Set columna = DatosConTotales.Resize(, 1)
indice = 0
For cuenta = 1 To datos.Columns.Count
If indice > UBound(listaFormatos) Then
indice = 0
End If
formato = Trim(listaFormatos(indice))
Select Case formato
Case "", "-":
'Nada
Case "H":
columna.EntireColumn.Hidden = True
Case Else:
columna.NumberFormat = formato
End Select
Set columna = columna.Offset(, 1)
indice = indice + 1
Next
End Function
Private Function Copiar(origen As Range, destino As Range) As Boolean
'Copia el rango origen en el destino.
'2009-IV-1
Call origen.Copy(destino)
End Function
Private Function OrdenarFilas(rango As Range) As Boolean
'Ordena las filas tomando como criterio de ordenacin la primera
columna,
'luego la segunda, y as hasta llegar a la ltima columna.
'
'Excel slo puede ordenar por tres campos a la vez.
'Para solucionar este problema ordenamos por las tres ltimas columnas,
' luego por las siguientes tres columnas a la izquierda de las anteriores
' y finalmente por las columnas que queden ms a la izquierda
'Ejemplo: call OrdenarFilas (sheets("ordenar").range("m3").currentregion)
'
' C 1
--> A 2
' B 3
B 1
' A 2
B 3
' B 1
C 1
'
'2009-IV-1 <fco@proinf.net>
'2009-IV-3 Empezar con lo que d el mdulo y luego de tres en tres
Dim
Dim
Dim
Dim

numCols As Integer
numTriosCompletos As Integer
trio As Integer
restoTrio As Integer

Dim ultimaColumna As Integer

numCols = rango.Columns.Count
numTriosCompletos = numCols \ 3
restoTrio = numCols Mod 3
ultimaColumna = numCols
Select Case restoTrio
Case 1:
rango.Sort _
key1:=rango.Cells(,
Case 2:
rango.Sort _
key1:=rango.Cells(,
key2:=rango.Cells(,
End Select
ultimaColumna = ultimaColumna -

ultimaColumna)
ultimaColumna - 1), _
ultimaColumna)
restoTrio

For trio = 1 To numTriosCompletos

rango.Sort _
key1:=rango.Cells(, ultimaColumna - 2), _
key2:=rango.Cells(, ultimaColumna - 1), _
key3:=rango.Cells(, ultimaColumna)
ultimaColumna = ultimaColumna - 3
Next
End Function
Private Function EliminarFilasDuplicadasConsecutivas(rango As Range) As
Integer
'Borra las filas consecutivos cuyos contenidos sean los mismos.
'
' A --> A
' A
' A
' B
B
' B
'
'2009-IV-3
Dim
Dim
Dim
Dim

filaOrigen As Range
filaDestino As Range
numFilas As Integer, fila As Integer
numFilasBorradas As Integer

numFilas = rango.Rows.Count
If numFilas > 1 Then
Set filaOrigen = rango.Resize(1)
Set filaDestino = filaOrigen.Offset(1)
For fila = 2 To numFilas
If RangosIguales(filaOrigen, filaDestino) Then
Call Borrar(filaDestino)
numFilasBorradas = numFilasBorradas + 1
Else
Set filaOrigen = filaDestino
End If

Set filaDestino = filaDestino.Offset(1)

Next
End If
EliminarFilasDuplicadasConsecutivas = numFilasBorradas
End Function
Private Function CompactarFilas(rango As Range) As Boolean
'Sube las filas inferiores aprovechando los huecos de filas vacas
'
' A --> A
' B
' ' B
' '
'2009-IV-3
On Error Resume Next '2009-IV-16; pasa a la linea siguiente sin mirar el
error
rango.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Function
Private Function DuplicarFilas(rango As Range, veces As Integer) As
Boolean
'Duplica cada fila el nmero de veces indicado
'
' A -2-> A
A -3-> A
' B
A
B
A
' C
B
A
'
B
B
'
C
B
'
C
B
'
'2009-IV-5
Dim
Dim
Dim
Dim

cuenta As Integer
numFilas As Integer
origen As Range
destino As Range

numFilas = rango.Rows.Count
Set origen = rango.Resize(1).Offset(numFilas)
Set destino = rango.Resize(veces).Offset(numFilas * veces)
For cuenta = 1 To numFilas
Set origen = origen.Offset(-1)
Set destino = destino.Offset(-veces)
Call Copiar(origen, destino)
Next
End Function
Private Function CombinarGrupos( _
rango As Range, _
Optional ByVal tipo As String = "COLUMNA", _
Optional ByVal indiceColorPar As Integer = COLOR_BLANCO, _

Optional ByVal combinar As Boolean = True _

) As Boolean
'Combina las celdas consecutivas con el mismo valor que se encuentren
' dentro de la misma columna o bien dentro de la misma fila segn est
' indicado en el parmetro tipo
'
' A A B B B --> A
B
' a b c d e
a b c d e
'
'2009-IV-3
'2009-V-12 parmetro combinar
Dim
Dim
Dim
Dim
Dim
Dim

numIteraciones As Integer, cuentaIteracion As Integer

numCeldas As Integer, cuentaCelda As Integer
avanceColumna As Integer, avanceFila As Integer
celdaInicio As Range, celdaOrigen As Range, celdaDestino As Range
grupo As Range
esPar As Boolean

If tipo <> "COLUMNA" And tipo <> "FILA" Then Exit Function
If tipo = "COLUMNA" Then
numIteraciones = rango.Columns.Count
numCeldas = rango.Rows.Count
avanceFila = 1
avanceColumna = 0
ElseIf tipo = "FILA" Then
numIteraciones = rango.Rows.Count
numCeldas = rango.Columns.Count
avanceFila = 0
avanceColumna = 1
End If
Set celdaInicio = rango.Cells(1)
For cuentaIteracion = 1 To numIteraciones
Set celdaOrigen = celdaInicio
Set celdaDestino = celdaOrigen.Offset(avanceFila, avanceColumna)
esPar = False
For cuentaCelda = 1 To numCeldas
If cuentaCelda = numCeldas Or celdaOrigen.Value <>
celdaDestino.Value Then
Set grupo = Range(celdaOrigen, celdaDestino.Offset(avanceFila, -avanceColumna))
If esPar Then grupo.Interior.ColorIndex = indiceColorPar
If combinar Then
With grupo
Dim valor As Variant
valor = .Cells(1).Value
.ClearContents
.Merge
.Cells(1).Value = valor
'.BorderAround xlContinuous, xlThin, COLOR_PLOMO
.HorizontalAlignment = xlCenter 'xlLeft
'xlGeneral
.VerticalAlignment = xlTop
End With

Else 'Sin combinar 2009-V-12

Dim celda As Range, celdaPrimera As Range
Dim formula As String
Set celdaPrimera = Nothing
For Each celda In grupo.Cells
If celdaPrimera Is Nothing Then
Set celdaPrimera = celda
formula = "=R" & celdaPrimera.Row & "C" &
celdaPrimera.Column
Else
celda.Font.ColorIndex =
celda.Interior.ColorIndex
''formula = "=R[<row>]C[<column>]"
''formula = Replace(formula, "<row>",
celdaPrimera.Row - celda.Row)
''formula = Replace(formula, "<column>",
celdaPrimera.Column - celda.Column)
celda.FormulaR1C1 = formula
End If
Next
End If
esPar = Not esPar
Set celdaOrigen = celdaDestino
End If
Set celdaDestino = celdaDestino.Offset(avanceFila,
avanceColumna)
Next
Set celdaInicio = celdaInicio.Offset(avanceColumna, avanceFila)
Next
End Function
Private Function BordearGruposCombinados( _
rango As Range, _
Optional ByVal tipo As String = "COLUMNA" _
) As Boolean
'Bordea los columnas de arriba a abajo o las filas de izquierda a derecha
' segn los datos de la primera fila o primera columna.
'De esta forma queda remarcado de forma ms patente los grupos
principales.
'
'
A
B
--> | A | B |
' a a b b b
|a a|b b b|
'
'2009-IV-5
Dim cuenta As Integer, maxCuenta As Integer
Dim amplitud As Integer
Dim grupo As Range
If tipo <> "COLUMNA" And tipo <> "FILA" Then Exit Function
If tipo = "FILA" Then
maxCuenta = rango.Rows.Count
Set grupo = rango.Resize(1)
rango.Resize(rango.Rows.Count, 1).Font.Bold = True
Else

maxCuenta = rango.Columns.Count
Set grupo = rango.Resize(, 1)
rango.Resize(1, rango.Columns.Count).Font.Bold = True
End If
cuenta = 1
Do Until cuenta > maxCuenta
If tipo = "FILA" Then
amplitud = grupo.Cells(1).MergeArea.Rows.Count
Set grupo = grupo.Resize(amplitud)
Else
amplitud = grupo.Cells(1).MergeArea.Columns.Count
Set grupo = grupo.Resize(, amplitud)
End If
With grupo
.BorderAround xlContinuous, xlMedium, COLOR_NEGRO
End With
cuenta = cuenta + amplitud
If tipo = "FILA" Then
Set grupo = grupo.Offset(amplitud)
Else
Set grupo = grupo.Offset(, amplitud)
End If

Loop

End Function
Private Function BordearGrupos( _
rango As Range, _
Optional ByVal tipo As String = "COLUMNA" _
) As Boolean
'Bordea los columnas de arriba a abajo o las filas de izquierda a derecha
' segn los datos de la primera fila o primera columna.
'De esta forma queda remarcado de forma ms patente los grupos
principales.
'
' A A B B B --> |A A|B B B|
' a a b b b
|a a|b b b|
'
'2009-IV-12
Dim
Dim
Dim
Dim
Dim

numCeldas As Integer, cuentaCelda As Integer

avanceColumna As Integer, avanceFila As Integer
celdaOrigen As Range, celdaDestino As Range
grupo As Range
amplitud As Integer

If tipo <> "COLUMNA" And tipo <> "FILA" Then Exit Function
If tipo = "FILA" Then
numCeldas = rango.Rows.Count
avanceFila = 1: avanceColumna = 0
amplitud = rango.Columns.Count

ElseIf tipo = "COLUMNA" Then

numCeldas = rango.Columns.Count
avanceFila = 0: avanceColumna = 1
amplitud = rango.Rows.Count
End If
Set celdaOrigen = rango.Cells(1)
Set celdaDestino = celdaOrigen.Offset(avanceFila, avanceColumna)
For cuentaCelda = 1 To numCeldas
If cuentaCelda = numCeldas Or celdaOrigen.Value <>
celdaDestino.Value Then
Set grupo = Range(celdaOrigen, celdaDestino.Offset(avanceFila, -avanceColumna))
If tipo = "FILA" Then
Set grupo = grupo.Resize(, amplitud)
Else
Set grupo = grupo.Resize(amplitud)
End If
With grupo
.BorderAround xlContinuous, xlMedium, COLOR_NEGRO
.Cells(1).Font.Bold = True
End With
Set celdaOrigen = celdaDestino
End If
Set celdaDestino = celdaDestino.Offset(avanceFila, avanceColumna)

Next
End Function

Private Function Transponer(origen As Range, destino As Range) As Boolean

'Copia el rango cambiando filas por columnas y viceversa.
'
' A --> A B C
' B
' C
'
'2009-IV-3
'Este mtodo no me gusta porque modifica el contenido del
portapapeles de Windows
'''origen.Copy
'''destino.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
Transpose:=True
'''Application.CutCopyMode = False
Dim numFilas As Integer, fila As Integer
Dim numColumnas As Integer, columna As Integer
numFilas = origen.Rows.Count
numColumnas = origen.Columns.Count
If numFilas >= 256 Then
MsgBox "Hay demasiados datos" & vbCrLf & _
"Una hoja de clculo no puede tener ms de 256 columnas",
vbExclamation

Transponer = False
Else

For fila = 1 To numFilas

For columna = 1 To numColumnas
destino.Cells(columna, fila).Value = origen.Cells(fila,
columna).Value
Next
Next
Transponer = True
End If
End Function
Private Function Borrar(rango As Range) As Boolean
'Elimina el contenido de las celdas.
'2009-IV-3
rango.Clear
End Function
Private Function Rellenar(origen As Range, destino As Range) As Boolean
'Copia N veces el rango origen en el rango destino.
'
' A B --> A B A B A B ...
'
'2009-IV-3
On Error Resume Next '2009-IV-21
origen.AutoFill Destination:=destino, Type:=xlFillDefault
End Function
Private Function RellenarFormato(origen As Range, destino As Range) As
Boolean
'Copia el formato de origen en destino
'2009-IV-5
Dim indDest As Integer, numDest As Integer
Dim indOrig As Integer, numOrig As Integer
numOrig = origen.Cells.Count
numDest = destino.Cells.Count
indOrig = 1
For indDest = 1 To numDest
'''destino.Cells(indDest).Value = 0
destino.Cells(indDest).NumberFormat =
origen.Cells(indOrig).NumberFormat
indOrig = indOrig + 1
If indOrig > numOrig Then
indOrig = 1
End If
Next
End Function
Private Function Totalizar(origen As Range, destino As Range,
listaFormulas As Variant) As Boolean
'Crea una fila con el total de cada columna
'

'Parmetro listaFormulas:
' Ej.: "S;;A;" significa la 1columna sumar, la 2 nada, la 3
promedio y la 4 nada
' Ej: "S-A-"
' Ej: "=SUM(<>);;=AVERAGE(<>);=RC[-1]/RC[-2]"
' Abreviaturas: S=suma, A=promedio, -=nada
'
'2009-IV-5
Dim
Dim
Dim
Dim
Dim
Dim
Dim

indiceColumna As Integer, numColumnas As Integer

indiceFormula As Integer
columna As Range
celdaFormula As Range
inicio As Range, fin As Range
rango As String
formula As String

numColumnas = origen.Columns.Count
Set columna = origen.Resize(, 1)
Set inicio = columna.Cells(1)
Set fin = columna.Cells(origen.Rows.Count)
Set celdaFormula = destino.Resize(1, 1)
rango = "R[<inicio>]C[<columna>]:R[<fin>]C[<columna>]"
rango = Replace(rango, "<columna>", inicio.Column celdaFormula.Column)
rango = Replace(rango, "<inicio>", inicio.Row - celdaFormula.Row)
rango = Replace(rango, "<fin>", fin.Row - celdaFormula.Row)
indiceFormula = LBound(listaFormulas)
For indiceColumna = 1 To numColumnas
formula = listaFormulas(indiceFormula)
Select Case formula 'Alias para las frmulas
Case "S": formula = "=SUM(<>)"
Case "A": formula = "=AVERAGE(<>)"
End Select
If formula <> "" Then
formula = Replace(formula, "<>", rango)
celdaFormula.NumberFormat = columna.Cells(1).NumberFormat
If Left(formula, 1) = "=" Then
celdaFormula.FormulaR1C1 = formula
Else
celdaFormula.Value = formula
End If
End If
If indiceFormula = UBound(listaFormulas) Then
indiceFormula = LBound(listaFormulas)
Else
indiceFormula = indiceFormula + 1
End If
Set columna = columna.Offset(, 1)

Set celdaFormula = celdaFormula.Offset(, 1)

Next
End Function
Private Function CrearGraficos( _
rangoDatos As Range, _
numColsTitulo As Integer, numFilasTitulo As Integer, numDatos As
Integer, _
ByVal tiposGraficos As Variant _
) As Boolean
'Crea un grfico por cada ttulo de datos
'
'
+--------------------+
'
|nfilasTitulo
|
'+--------------+--------+-----------+
'|
|nDatos | ...
|
'+--------------+--------+-----------+
'| ncolsTitulo | rangoDatos
|
'|
|
|
'+--------------+--------------------+
'
'El parmetro "tipos de grficos" codifica un tipo de grfico diferente
para cada dato:
'
Ej: "C-S-"
'
Ej: "C;;S;"
'
Abreviaturas: C=columnas,S=columnas
apiladas,A=rea,L=lnea,B=barras,P=tarta
'
'2009-V-7, 2009-x-5
On Error GoTo Errores
Dim rangoEncabezado As Range
Dim rangoInicialGrafico As Range
Dim rangoTitulos As Range
Dim rangoGrafico As Range
Dim rangoColumna As Range
Dim celda As Range
Dim indiceTipo As Integer
Dim indice As Integer, cuenta As Integer
Dim grafico As Chart
Dim tipoGrafico As Variant 'XlChartType
Dim hojaDelantera As Object
Set rangoEncabezado = rangoDatos.Offset(-numFilasTitulo 1).Resize(numFilasTitulo)

Set rangoInicialGrafico = Union( _

rangoEncabezado.Resize(, numColsTitulo).Offset(, -numColsTitulo),
rangoDatos.Resize(, numColsTitulo).Offset(, -numColsTitulo))
Set rangoTitulos = rangoDatos.Offset(-1).Resize(1, numDatos)
Set hojaDelantera = rangoDatos.Worksheet
indiceTipo = LBound(tiposGraficos)

cuenta = 1
For Each celda In rangoTitulos.Cells
tipoGrafico = tiposGraficos(indiceTipo)
If Not IsNumeric(tipoGrafico) Then
'Alias para los grficos
Select Case tiposGraficos(indiceTipo)
Case "C": tipoGrafico = xlColumnClustered
Case "S": tipoGrafico = xlColumnStacked
Case "A": tipoGrafico = xlAreaStacked
Case "L": tipoGrafico = xlLine
Case "B": tipoGrafico = xlBarClustered
Case "P": tipoGrafico = xlPie
Case Else: tipoGrafico = 0
End Select
End If
If tipoGrafico <> 0 Then
Set rangoGrafico = rangoInicialGrafico
For indice = cuenta To rangoDatos.Columns.Count Step numDatos
Set rangoGrafico = Union(rangoGrafico, _
rangoEncabezado.Columns(indice),
rangoDatos.Columns(indice))
Next
Set grafico = Charts.Add(After:=hojaDelantera) '2009-V-12
Set hojaDelantera = grafico
With grafico
.ChartType = tipoGrafico
.SetSourceData source:=rangoGrafico, PlotBy:=xlRows
.Location Where:=xlLocationAsNewSheet
.Name = NuevoNombreHoja("grafico " & celda.Value)

= "equis"

.HasTitle = True
.ChartTitle.Characters.Text = celda.Value
.Axes(xlCategory, xlPrimary).HasTitle = False
'''.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text
.Axes(xlValue, xlPrimary).HasTitle = False
'''.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text =

"ygriega"

End With
End If
If indiceTipo = UBound(tiposGraficos) Then
indiceTipo = LBound(tiposGraficos)
Else
indiceTipo = indiceTipo + 1
End If
cuenta = cuenta + 1

Next
CrearGraficos = True
Salida: 'es etiqueta, no variable
Exit Function
Errores:

Select Case Err.Number

Case 1004: MsgBox "El grfico tiene demasiados datos a
analizar", vbInformation
Case Else: MsgBox Err.Description, vbCritical, "Error n" &
Err.Number
End Select
Resume Salida
End Function
Private Function AutoajustarColumnas(rango As Range) As Boolean
'2009-V-21
'Este mtodo no conviene porque muestra las columnas ocultas, las
que tienen ancho 0
'''rango.EntireColumn.AutoFit
Dim columna As Range
For Each columna In rango.Columns
If Not columna.Hidden Then
columna.EntireColumn.AutoFit
End If
Next
End Function
'-----------------------------------------------' OTRAS AUXILIARES
'-----------------------------------------------Private Function RangosIguales(origen As Range, destino As Range) As
Boolean
'Indica si los contenidos de los dos rangos coinciden
'2009-IV-3
Dim celdaOrigen As Range
Dim celdaDestino As Range
Dim indiceDestino As Integer
If origen.Cells.Count = destino.Cells.Count Then
indiceDestino = 1
Set celdaDestino = destino.Cells(indiceDestino)
For Each celdaOrigen In origen.Cells
If CStr(celdaOrigen.Value) <> CStr(celdaDestino.Value) Then
'2009-IV-16
RangosIguales = False
Exit Function
End If
indiceDestino = indiceDestino + 1
Set celdaDestino = destino.Cells(indiceDestino)
Next
RangosIguales = True
Else
RangosIguales = False
End If

End Function
Private Function PatronEnArray(ByVal patron As Variant, ByVal colsDatos
As Integer) As Variant
'2009-V-12
If Not IsArray(patron) Then
If patron = "" Then patron = "-"
If InStr(patron, SEPARADOR_LISTA) Then
patron = Split(patron, SEPARADOR_LISTA)
Else
patron = CaracteresEnArray(UCase(Left(patron &
String(colsDatos, Left(patron, 1)), colsDatos)))
End If
End If
PatronEnArray = patron
End Function

Attribute VB_Name = "moduloGenerico_2009_05_12"

Option Explicit
'Mdulo genrico
'2009-V-12 <fco@proinf.net>
'-----------------------------------------------' FUNCIONES PUBLICAS
'-----------------------------------------------Public Function dejarAlgunosCaracteres( _
ByVal texto As String, _
ByVal caracteresValidos As String _
) As String
'Elimina del texto todos los caracteres que no estn incluidos en
caracteres vlidos
'Ej: "AB1ACD3B" --"ABC"--> "ABACB"
'2009-V-12
Dim lista As Variant
Dim indice As Integer
Dim caracter As String
texto = Trim(texto)
ReDim lista(Len(texto) - 1)

For indice = 1 To Len(texto)

caracter = Mid(texto, indice, 1)
If InStr(caracteresValidos, caracter) Then
lista(indice - 1) = caracter
End If
Next
dejarAlgunosCaracteres = Join(lista, "")
End Function
Public Function CaracteresEnArray(ByVal texto As String) As Variant
'Convierte los caracteres de un texto en un array
'Ej: ? join(CaracteresEnArray("hola"),";") --> "h;o;l;a"
'2009-V-12
Dim lista As Variant
Dim indice As Integer
ReDim lista(Len(texto) - 1)
For indice = 1 To Len(texto)
lista(indice - 1) = Mid(texto, indice, 1)
Next
CaracteresEnArray = lista
End Function

Attribute VB_Name = "moduloColor_2010_06_03"

Option Explicit
'Gestin del color
'2009-III-25 <fco@proinf.net>
'2009-IV-23 - Color par e impar
'-----------------------------------------------' INDICES DE COLOR
'-----------------------------------------------Public Const COLOR_PAR = 0
Public Const COLOR_IMPAR = 1
Public Const COLOR_NEGRO = 1
Public Const COLOR_BLANCO = 2
Public Const COLOR_ROJ0 = 3
Public Const COLOR_TURQUESA = 8

Public Const COLOR_GRIS = 15

Public Const COLOR_PLOMO = 16
Public
Public
Public
Public
Public
Public
Public

Const
Const
Const
Const
Const
Const
Const

COLOR_CELESTE = 34
COLOR_MENTA = 35
COLOR_VAINILLA = 36
COLOR_CIELO = 37
COLOR_ROSA = 38
COLOR_LAVANDA = 39
COLOR_CANELA = 40

Public Const COLOR_AGUAMARINA = 42

Public Const COLOR_ANARANJADO = 45
Public Const COLOR_NARANJA = 46
Public Const COLOR_CENIZA = 56
'-----------------------------------------------' FUNCIONES PRUEBA
'-----------------------------------------------Public Sub PruebaModuloColor()
Call ColorearTresGrupos(Range("datos"), 2, 2, 2)
End Sub
'-----------------------------------------------' FUNCIONES
'-----------------------------------------------Public Function ColorearFilas( _
celdaDentroRango As Range, _
indiceColorImpar As Integer, _
indiceColorPar As Integer, _
columnaInicio As Integer, _
columnaFin As Integer _
)
'Colorea cebrando las filas desde y hasta las columnas indicadas
'Ignora la primera fila porque se considera que es una fila de ttulos
'2009-III-25 <fco@proinf.net>
Dim
Dim
Dim
Dim

tabla As Range
celda As Range
par As Boolean
indiceColor As Integer

Set tabla = celdaDentroRango.CurrentRegion.Offset(, columnaInicio 1).Resize(, columnaFin - columnaInicio + 1)

'Eliminar fila de titulos
Set tabla = tabla.Offset(1).Resize(tabla.Rows.Count - 1)
For Each celda In tabla.Cells
par = (celda.Row Mod 2) = 0
indiceColor = IIf(par, indiceColorPar, indiceColorImpar)
celda.Interior.ColorIndex = indiceColor

Next
End Function
Public Function Colorear(ParamArray params())
'Colorea el fondo de los rangos indicados con los colores indicados
'Ejemplo: Call Colorear (COLOR_ROJO, Range("A1:A4"), Range("B3"),
COLOR_AZUL, Range("C2"))
'2009-IV-1 <fco@proinf.net>
Dim indiceColor As Integer
Dim rango As Range
Dim elemento As Variant
For Each elemento In params
If IsObject(elemento) Then
Set rango = elemento
If indiceColor <> 0 Then
rango.Interior.ColorIndex = indiceColor
If indiceColor = COLOR_NEGRO Or indiceColor = COLOR_PLOMO

Then

rango.Font.ColorIndex = COLOR_BLANCO
End If
End If
ElseIf IsNumeric(elemento) Then
indiceColor = elemento
End If
Next
End Function
Public Function CebrarFilas( _
rango As Range, _
Optional ByVal indiceColorPar = COLOR_BLANCO _
) As Boolean
'Colorea las filas pares del rango indicado.
'2009-IV-3
Dim fila As Range
Dim indiceFila As Integer, numFilas As Integer
Dim esPar As Boolean
numFilas = rango.Rows.Count
Set fila = rango.Resize(1)
For indiceFila = 1 To numFilas
If esPar Then
fila.Interior.ColorIndex = indiceColorPar
End If
esPar = Not esPar
Set fila = fila.Offset(1)
Next
End Function
Public Function Cuadricular( _
rango As Range _
) As Boolean
'Bordea las celdas del rango indicado

'2009-IV-5
With rango.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = COLOR_PLOMO
End With
End Function
Public Function ColorearColumnas( _
rango As Range, _
numElementos As Integer, _
indicesColor As Variant _
) As Boolean
'Colorea de N en N columnas con la lista de colores indicados.
'2009-IV-5
Dim columna As Range
Dim indiceColumna As Integer, numColumnas As Integer
Dim indiceElemento As Integer
Dim indiceColor As Integer, numColores As Integer
numColumnas = rango.Columns.Count
numColores = 1 ' UBound(indicesColor) + 1 '2010-VI-3
Set columna = rango.Resize(, 1)
For indiceColumna = 1 To numColumnas
With columna.Interior
.ColorIndex = indicesColor(indiceColor)
End With
indiceElemento = indiceElemento + 1
If indiceElemento >= numElementos Then
indiceElemento = 0
End If
indiceColor = indiceColor + 1 'indiceElemento '2010-VI-3
If indiceColor >= numColores Then
indiceColor = 0
End If
Set columna = columna.Offset(, 1)

Next

End Function
Public Function ColorearTresGrupos( _
inicioRango As Range, _
numColumnas1 As Integer, _
numColumnas2 As Integer, _
numColumnas3 As Integer _
)
'Colorea cebrando las filas de tres grupos de columnas consecutivos
'2009-III-25 <fco@proinf.net>
'2010-VI-3 - Nuevos colores

Dim columnaInicio As Integer

Dim columnaFin As Integer
columnaInicio = columnaFin + 1
columnaFin = columnaInicio + numColumnas1 - 1
Call ColorearFilas(inicioRango, COLOR_CIELO, COLOR_BLANCO,
columnaInicio, columnaFin)
columnaInicio = columnaFin + 1
columnaFin = columnaInicio + numColumnas2 - 1
Call ColorearFilas(inicioRango, COLOR_CANELA, COLOR_BLANCO,
columnaInicio, columnaFin)
columnaInicio = columnaFin + 1
columnaFin = columnaInicio + numColumnas3 - 1
Call ColorearFilas(inicioRango, COLOR_MENTA, COLOR_BLANCO,
columnaInicio, columnaFin)
End Function
'-----------------------------------------------'Color definido para las filas impares y pares de la tabla destino.
Public Function ColorColumnas(Optional numColor As Integer) As Integer
Select Case numColor Mod 2
Case COLOR_PAR: ColorColumnas = COLOR_CELESTE 'COLOR_ANARANJADO
Case COLOR_IMPAR: ColorColumnas = COLOR_CIELO 'COLOR_NARANJA
End Select
End Function
Public Function ColorFilas(Optional numColor As Integer) As Integer
Select Case numColor Mod 2
Case COLOR_PAR: ColorFilas = COLOR_CELESTE 'COLOR_TURQUESA
Case COLOR_IMPAR: ColorFilas = COLOR_CIELO 'COLOR_AGUAMARINA
End Select
End Function
Public Function ColorDatos(Optional numColor As Integer) As Integer
Select Case numColor Mod 2
Case COLOR_PAR: ColorDatos = COLOR_BLANCO
Case COLOR_IMPAR: ColorDatos = COLOR_MENTA
End Select
End Function
Public Function colorTitulos(Optional numColor As Integer) As Integer
colorTitulos = COLOR_PLOMO
End Function
Public Function colorFormula(Optional numColor As Integer) As Integer
colorFormula = COLOR_GRIS
End Function
'-----------------------------------------------Attribute VB_Name = "moduloFormulas_2008_07_15"
Option Explicit
'Funciones para frmulas de las celdas
'2008-VII-15 <fco@proinf.net>
Public Function NoError( _
ByVal valor As Variant, _

Optional ByVal valorOmision As Variant = Null _

) As Variant
'Evita el error de divisin por cero en las frmulas de clculo de
precios
'2008-VII-15 <fco@proinf.net>
If IsError(valor) Then
NoError = 0
Else
NoError = valor
End If
End Function

Attribute VB_Name = "moduloMacrosEjemplo"

Option Explicit
Public Sub MacroEjemplo1_1()
Worksheets("ejemplo1").Range("I:IV").EntireColumn.Delete
Call CrearTablaCartesiana( _
Worksheets("ejemplo1").Range("B2"), _
Worksheets("ejemplo1").Range("I2"), _
1, 3, 2, _
opcionFijar:=False, _
opcionAjustar:=False)
End Sub
Public Sub MacroEjemplo1_2()
Worksheets("ejemplo1").Range("I:IV").EntireColumn.Delete
Call CrearTablaCartesiana( _
Worksheets("ejemplo1").Range("B2"), _
Worksheets("ejemplo1").Range("I2"), _
2, 2, 2, _
opcionFijar:=False, _
opcionAjustar:=False)
End Sub
Public Sub MacroEjemplo2_1()
Worksheets("ejemplo2").Range("K:IV").EntireColumn.Delete
Call CrearTablaCartesiana( _
Worksheets("ejemplo2").Range("B2"), _
Worksheets("ejemplo2").Range("K2"), _
1, 3, 4, _
opcionFijar:=False, _
opcionAjustar:=False)
End Sub
Public Sub MacroEjemplo2_2()
Worksheets("ejemplo2").Range("K:IV").EntireColumn.Delete

Call CrearTablaCartesiana( _
Worksheets("ejemplo2").Range("B2"), _
Worksheets("ejemplo2").Range("K2"), _
2, 2, 4, _
opcionFijar:=False, _
opcionAjustar:=False)
End Sub
Public Sub MacroEjemplo3_1()
Worksheets("destino").Range("A:IV").EntireColumn.Delete
Call CrearTablaCartesiana( _
Worksheets("origen").Range("B2"), _
Worksheets("destino").Range("B2"), _
1, 3, 4)
End Sub
Public Sub MacroEjemplo3_2()
Worksheets("destino").Range("A:IV").EntireColumn.Delete
Call CrearTablaCartesiana( _
Worksheets("origen").Range("B2"), _
Worksheets("destino").Range("B2"), _
2, 2, 4)
End Sub
Public Sub MacroVerCodigoFuente()
SendKeys "%{F11}"
End Sub

Attribute VB_Name = "moduloMacros_2009_05_12"

Option Explicit
Private numCols As Integer
Private numFils As Integer
Private numDatos As Integer

Public Sub MacroCrearTablaCartesiana( _

ByVal colsColumnas As Integer, _
ByVal colsFilas As Integer, _
ByVal colsDatos As Integer, _
Optional ByVal patronGraficos As Variant = "", _
Optional ByVal patronTotales As Variant = "", _
Optional ByVal patronFormatos As Variant = "" _
)
'2009-V-12
Dim opcionGraficos As Boolean
Dim opcionTotales As Boolean
opcionGraficos = patronGraficos <> ""
opcionTotales = patronTotales <> ""
Call CrearTablaCartesiana( _
Worksheets("datos").Range("datos"), _
Worksheets("reporte").Range("reporte"), _
colsColumnas, colsFilas, colsDatos, _
opcionFijar:=False, _
opcionGraficos:=opcionGraficos, patronGraficos:=patronGraficos, _
opcionTotales:=opcionTotales, patronTotales:=patronTotales, _
patronFormatos:=patronFormatos _
)
Worksheets("reporte").Activate
Worksheets("datos").Visible = False
'Recordar
numCols = colsColumnas
numFils = colsFilas
numDatos = colsDatos
End Sub
Public Sub MacroCrearTablaDinamica()
Call CrearTablaDinamica( _
Worksheets("datos").Range("datos").CurrentRegion, _
numCols, numFils, numDatos)
End Sub
'Public Sub MacroTest()
'
Call CrearTablaCartesiana( _
'
Worksheets("datos").Range("datos"), _
'
Worksheets("reporte").Range("a5"), _
'
2, 2, 4, _
'
opcionFijar:=False)
'End Sub

Attribute VB_Name = "moduloHojas_2009_05_12"

Option Explicit

'Mdulo Hojas
'2009-V-7 versin 1.0 <fco@proinf.net>
'2009-V-12
'-----------------------------------------------' CONSTANTES
'-----------------------------------------------Public Const NUM_FILS_HOJA_CALCULO = 65536
Public Const NUM_COLS_HOJA_CALCULO = 256
'-----------------------------------------------' FUNCIONES PRINCIPALES
'-----------------------------------------------Public Function NuevoNombreHoja(Optional ByVal nombre As String = "") As
String
'Obtiene un nombre de hoja vlido que no est duplicado.
'No crea la hoja slo da el posible nombre que podra tener.
'2009-V-7
Dim nuevoNombre As String
Dim contador As Integer
nombre = NormalizarNombreHoja(nombre)
If nombre = "" Then
nombre = "hoja"
End If
nuevoNombre = nombre
contador = 1
Do Until Not ExisteNombreHoja(nuevoNombre)
contador = contador + 1
nuevoNombre = nombre & contador
Loop
NuevoNombreHoja = nuevoNombre
End Function
Public Function BorrarDatosHoja(ByVal nombre As String) As Boolean
'2009-V-7
Worksheets(nombre).Range("A:IV").EntireColumn.Delete
End Function
Public Function BorrarHojas(ByVal patron As String) As Boolean
'Borra todas las hojas cuyo nombre casen con el patrn indicado
'Ejemplo: BorrarHojas("grafico*") borra todas las hojas que se llamen
grafico
'2009-V-7
Dim lista As Variant
Dim nombre As Variant
lista = ListaHojas(patron)
Application.DisplayAlerts = False

For Each nombre In lista

Sheets(nombre).Delete
Next
Application.DisplayAlerts = True
End Function
'-----------------------------------------------' FUNCIONES AUXILIARES
'-----------------------------------------------Private Function ListaHojas(ByVal patron As String) As Variant
'El patron puede tener asterisco delante, detrs o delante y detrs.
'Por ejemplo: "*hoja*" retorna todas los nombre de hoja que incluya la
palabra hoja
'
Join(ListaHojas("ejemplo*"),",")
'2009-V-7
Const ELEMENTO_SEPARADOR = "/"
Dim
Dim
Dim
Dim
Dim

hoja As Object 'Ni Sheet ni Worksheet van bien

tipo As String
lista As String
nombre As String
ok As Boolean

If Left(patron, 1) = "*" And Right(patron, 1) = "*" Then

tipo = "CONTIENE"
ElseIf Left(patron, 1) = "*" Then
tipo = "ACABA"
ElseIf Right(patron, 1) = "*" Then
tipo = "EMPIEZA"
Else
tipo = "ES"
End If
patron = Replace(patron, "*", "")
For Each hoja In Sheets
nombre = hoja.Name
ok = False
Select Case tipo
Case "ES":
ok = patron = nombre
Case "EMPIEZA": ok = patron = Left(nombre, Len(patron))
Case "ACABA":
ok = patron = Right(nombre, Len(patron))
Case "CONTIENE": ok = 0 <> InStr(nombre, patron)
End Select
If ok Then
If lista <> "" Then lista = lista & ELEMENTO_SEPARADOR
lista = lista & nombre
End If
Next
ListaHojas = Split(lista, ELEMENTO_SEPARADOR)
End Function
Private Function ExisteNombreHoja(ByVal nombre As String) As Boolean
'Comprueba si existe el nombre de hoja indicado en el libro actual
'2009-V-7

Dim hoja As Object 'Ni Sheet ni Worksheet van bien

For Each hoja In Sheets
If LCase(hoja.Name) = LCase(nombre) Then
ExisteNombreHoja = True
Exit Function
End If
Next
ExisteNombreHoja = False
End Function
Private Function NormalizarNombreHoja(ByVal nombre As String) As String
'Deja slos caracteres alfanumricos, el guin, el guin bajo y el
espacio
'Elimina el resto de caracteres entre ellos los acentos y signos de
puntuacin
'2009-V-7
Const CARACTERES_VALIDOS =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_ "
NormalizarNombreHoja = Trim(dejarAlgunosCaracteres(nombre,
CARACTERES_VALIDOS))
End Function