moduloCartesiano_2009_12_04.bas

  1. Attribute VB_Name = "moduloCartesiano_2009_12_04"
  2. Option Explicit
  3.  
  4. 'Módulo Cartesiano
  5. ' Entrada:
  6. ' Una tabla de agrupación. Las columnas indican niveles de agrupación en detalle
  7. ' creciente. Las últimas columnas son los datos
  8. '
  9. ' Salida:
  10. ' Una nueva tabla dónde algunas de las primeras columnas de agrupación
  11. ' se han dispuesto en forma horizontal. Semejante a un producto cartesiano
  12. ' o semejante a una tabla dinámica
  13. '
  14. '2009-IV-1 versión 1.0 <fco@proinf.net>
  15. '2009-IV-16 version 1.1 -
  16. '2009-IV-21 versión 1.2 -
  17. '2009-V-7 versión 1.3 - Poder quitar títulos y agregar gráficos
  18. '2009-V-12 versión 1.4 - Mejorar gráficos y totales
  19. '2009-V-14 versión 1.5 - Tabla dinámica y gráfico dinámico
  20. '2009-V-21 versión 1.6 - Parámetro patronFormatos
  21. '2009-X-5 version 1.7 - Control de errores al crear gráfico
  22. '2009-XII-4 versión 1.8 - Controlar en Transponer cuando hay 256 columnas
  23.  
  24. '------------------------------------------------
  25. ' CONSTANTES
  26. '------------------------------------------------
  27.  
  28. Const SEPARADOR_LISTA = ";"
  29.  
  30. '------------------------------------------------
  31. ' FUNCIONES DE PRUEBA
  32. '------------------------------------------------
  33.  
  34. Public Sub PruebaModuloCartesiano()
  35. '2009-IV-3
  36. 'Dim prueba As Worksheet
  37. 'Dim rango As Range, rango2 As Range
  38. 'Set prueba = Sheets("pruebas")
  39. 'Set rango = prueba.Range("m3").CurrentRegion
  40. 'Set rango2 = prueba.Range("q3").CurrentRegion
  41.  
  42. 'PRUEBAS INDIVIDUALES
  43. 'Call OrdenarFilas(rango)
  44. 'Call EliminarFilasDuplicadasConsecutivas(rango)
  45. 'Call CompactarFilas(rango)
  46. 'Call CombinarGrupos(rango, "COLUMNA")
  47. 'Call Transponer(rango, rango2)
  48. 'Call CombinarGrupos(rango2, "FILA")
  49. 'Call Rellenar(prueba.Range("q6:r6"), prueba.Range("q6:ab6"))
  50. 'Call BordearGrupos(Sheets("destino").Range("B5:I10"), "FILA")
  51. 'Call BordearGrupos(Sheets("destino").Range("D2:I10"), "COLUMNA")
  52.  
  53. 'Call CrearTablaCartesiana( _
  54.   Worksheets("Hoja1").Range("B2"), _
  55.   Worksheets("Hoja1").Range("B26"), _
  56.   2, 2, 2, _
  57.   opcionFijar:=False, _
  58.   opcionAjustar:=False)
  59.  
  60. 'Prueba GENERAL
  61. Call BorrarDatosHoja("destino")
  62. Call BorrarHojas("grafico*")
  63. Call BorrarHojas("*dinamica")
  64.  
  65. Call CrearTablaCartesiana( _
  66. Worksheets("origen").Range("B2"), _
  67. Worksheets("destino").Range("B2"), _
  68. 2, 2, 4, _
  69. opcionFijar:=False, _
  70. opcionTitulos:=True, _
  71. opcionGraficos:=True, _
  72. patronGraficos:="C-B-", _
  73. patronTotales:="SASA")
  74.  
  75. Call CrearTablaDinamica( _
  76. Worksheets("origen").Range("B2").CurrentRegion, _
  77. 2, 2, 4)
  78. End Sub
  79.  
  80. '------------------------------------------------
  81. ' FUNCION PRINCIPAL
  82. '------------------------------------------------
  83.  
  84. Public Function CrearTablaCartesiana( _
  85. ByVal origen As Range, ByVal destino As Range, _
  86. ByVal colsColumnas As Integer, ByVal colsFilas As Integer, ByVal colsDatos As Integer, _
  87. Optional ByVal opcionTotales As Boolean = True, _
  88. Optional ByVal opcionGraficos As Boolean = False, _
  89. Optional ByVal opcionCombinar As Boolean = True, _
  90. Optional ByVal opcionFormatear As Boolean = True, _
  91. Optional ByVal opcionRatios As Boolean = True, _
  92. Optional ByVal opcionAjustar As Boolean = True, _
  93. Optional ByVal opcionFijar As Boolean = True, _
  94. Optional ByVal opcionTitulos As Boolean = True, _
  95. Optional ByVal patronTotales As Variant = "S", _
  96. Optional ByVal patronGraficos As Variant = "C", _
  97. Optional ByVal patronFormatos As Variant = "" _
  98. ) As Boolean
  99. 'Función principal
  100. '
  101. ' Origen Destino
  102. '
  103. ' TC TF TD TC c1 c2
  104. ' c1 f1 d1 TF TD TD
  105. ' c1 f2 d2 --> f1 d1 d3
  106. ' c2 f1 d3 f2 d2 d4
  107. ' c4 f2 d4
  108. '
  109. '
  110. ' Patrón totales:
  111. ' Ej: "S-A-"
  112. ' Ej: "=SUM(<>);;=AVERAGE(<>);=RC[-1]/RC[-2]"
  113. ' Abreviaturas: S=suma, A=promedio, -=nada
  114. '
  115. ' Patrón gráficos:
  116. ' Ej: "C-S-"
  117. ' Ej: "C;;S;"
  118. ' Abreviaturas: C=columnas,S=columnas apiladas,A=área,L=línea,B=barras,P=tarta
  119. '
  120. ' Patrón formatos:
  121. ' Ej: "-H-" oculta la segunda columna de datos
  122. ' Ej: ";#.##0" formatea la segunda columna
  123. '
  124. '2009-IV-1 <fco@proinf.net>
  125. '2009-IV-5
  126. '2009-IV-23 Opción títulos y opción gráficos
  127. '2009-V-12 Patrón de totales y gráficos
  128.  
  129. 'Comprobación inicial
  130. If colsColumnas <= 0 Or colsFilas <= 0 Or colsDatos <= 0 Then '2009-V-19
  131. Exit Function
  132. End If
  133.  
  134. 'Inicialización
  135. Application.ScreenUpdating = False 'TRUE=para depurar, FALSE=versión final
  136.  
  137. 'Declaración de variables
  138. Dim origenTitulosColumnas As Range, destinoTitulosColumnas As Range
  139. Dim origenTitulosFilas As Range, destinoTitulosFilas As Range
  140. Dim origenTitulosDatos As Range, destinoTitulosDatos As Range
  141.  
  142. Dim origenColumnas As Range, destinoColumnas As Range
  143. Dim origenFilas As Range, destinoFilas As Range
  144. Dim origenDatos As Range, destinoDatos As Range
  145.  
  146. Dim destinoTitulosTotal As Range, destinoTotal As Range
  147.  
  148. Dim rangoTrabajo As Range
  149.  
  150. Dim filasOrigen As Integer
  151.  
  152. Dim filas As Integer, columnas As Integer, rango As Range
  153.  
  154. 'Corregir parámetros
  155. Set origen = origen.CurrentRegion
  156. Set destino = destino.Range("A1")
  157.  
  158. 'Averiguar rangos
  159. filasOrigen = origen.Rows.Count
  160.  
  161. Set origenColumnas = origen.Offset(1, 0).Resize(filasOrigen - 1, colsColumnas)
  162. Set origenFilas = origen.Offset(1, colsColumnas).Resize(filasOrigen - 1, colsFilas)
  163. Set origenDatos = origen.Offset(1, colsColumnas + colsFilas).Resize(filasOrigen - 1, colsDatos)
  164. '''
  165. Set origenTitulosColumnas = origenColumnas.Offset(-1, 0).Resize(1)
  166. Set origenTitulosFilas = origenFilas.Offset(-1, 0).Resize(1)
  167. Set origenTitulosDatos = origenDatos.Offset(-1, 0).Resize(1)
  168.  
  169. Set destinoColumnas = destino.Offset(0, colsFilas)
  170. Set destinoFilas = destino.Offset(colsColumnas + 1, 0)
  171. Set destinoDatos = destino.Offset(colsColumnas + 1, colsFilas)
  172. '''
  173. Set destinoTitulosColumnas = destinoColumnas.Offset(, -1)
  174. Set destinoTitulosFilas = destinoFilas.Offset(-1)
  175. Set destinoTitulosDatos = destinoDatos.Offset(-1)
  176.  
  177. 'Comprobación visual
  178. If opcionFormatear Then
  179. Colorear ColorColumnas(COLOR_IMPAR), origenColumnas, destinoColumnas
  180. Colorear ColorFilas(COLOR_IMPAR), origenFilas, destinoFilas
  181. Colorear ColorDatos(COLOR_IMPAR), origenDatos, destinoDatos
  182.  
  183. If opcionTitulos Then
  184. Colorear colorTitulos, origenTitulosColumnas, origenTitulosFilas, origenTitulosDatos
  185. Colorear colorTitulos, destinoTitulosColumnas, destinoTitulosFilas, destinoTitulosDatos
  186. End If
  187. End If
  188.  
  189. 'Pasar las COLUMNAS
  190. Call Copiar(origenColumnas, destinoDatos)
  191. Set rangoTrabajo = destinoDatos.CurrentRegion
  192. Call OrdenarFilas(rangoTrabajo)
  193. Call EliminarFilasDuplicadasConsecutivas(rangoTrabajo)
  194. Call CompactarFilas(rangoTrabajo)
  195. Call DuplicarFilas(rangoTrabajo, veces:=colsDatos)
  196. Set rangoTrabajo = rangoTrabajo.CurrentRegion
  197. If Not Transponer(rangoTrabajo, destinoColumnas) Then Exit Function
  198. Set destinoColumnas = destinoColumnas.CurrentRegion
  199. Call Borrar(rangoTrabajo)
  200. If opcionFormatear Then
  201. Colorear ColorColumnas(COLOR_IMPAR), destinoColumnas
  202. destinoColumnas.Borders.LineStyle = xlNone
  203. End If
  204.  
  205. 'Pasar las FILAS
  206. Call Copiar(origenFilas, destinoFilas)
  207. Set rangoTrabajo = destinoFilas.CurrentRegion
  208. Call OrdenarFilas(rangoTrabajo)
  209. Call EliminarFilasDuplicadasConsecutivas(rangoTrabajo)
  210. Call CompactarFilas(rangoTrabajo)
  211. Set destinoFilas = destinoFilas.CurrentRegion
  212. If opcionFormatear Then
  213. Colorear ColorFilas(COLOR_IMPAR), destinoFilas
  214. destinoFilas.Borders.LineStyle = xlNone
  215. End If
  216.  
  217. 'Pasar los DATOS
  218. Set destinoDatos = destinoDatos.Resize(destinoFilas.Rows.Count, destinoColumnas.Columns.Count)
  219.  
  220. 'Titulos
  221. Call Copiar(origenTitulosDatos, destinoTitulosDatos)
  222. Set destinoTitulosDatos = destinoTitulosDatos.Resize(, destinoColumnas.Columns.Count)
  223. Call Rellenar(destinoTitulosDatos.Resize(, colsDatos), destinoTitulosDatos)
  224.  
  225. Call CopiarDatosCartesianos( _
  226. origenColumnas, destinoColumnas, _
  227. origenFilas, destinoFilas, _
  228. origenDatos, destinoDatos)
  229. Call Formular(destinoDatos, destinoTitulosDatos.Resize(, colsDatos))
  230.  
  231. '2009-V-21
  232. Call RellenarFormato(origenDatos.Resize(1), destinoDatos) '2009-XI-30
  233. patronFormatos = PatronEnArray(patronFormatos, colsDatos)
  234. Call FormatearDatos(destinoDatos, patronFormatos)
  235.  
  236. 'Comprobación visual
  237. If opcionFormatear Then
  238. Colorear ColorDatos(COLOR_IMPAR), destinoDatos, colorTitulos, destinoTitulosDatos
  239. Call ColorearColumnas(destinoDatos, colsDatos, Array(COLOR_MENTA, COLOR_CELESTE, COLOR_VAINILLA, COLOR_CANELA, COLOR_ROSA, COLOR_LAVANDA, COLOR_CIELO))
  240. Call CebrarFilas(destinoDatos, ColorDatos)
  241. Call Cuadricular(destinoDatos)
  242. End If
  243.  
  244. 'Fila de totales
  245. If opcionTotales Then
  246. patronTotales = PatronEnArray(patronTotales, colsDatos)
  247.  
  248. Set destinoTotal = destinoDatos.Offset(destinoDatos.Rows.Count).Resize(1)
  249. Call Totalizar(destinoDatos, destinoTotal, patronTotales)
  250. If opcionFormatear Then
  251. Colorear colorFormula, destinoTotal
  252. End If
  253. End If
  254.  
  255. 'Gráficos
  256. If opcionGraficos Then
  257. opcionCombinar = False
  258. patronGraficos = PatronEnArray(patronGraficos, colsDatos)
  259.  
  260. 'Por cada columna de datos crear una hoja de gráfico
  261. '''filas = destinoFilas.Rows.Count + colsColumnas + 1
  262. Call CrearGraficos( _
  263. destinoDatos, _
  264. destinoFilas.Columns.Count, _
  265. destinoColumnas.Rows.Count, _
  266. colsDatos, _
  267. patronGraficos)
  268. End If
  269.  
  270. 'Títulos
  271. If opcionTitulos Then
  272. 'Títulos de columnas
  273. Set destinoTitulosColumnas = destinoTitulosColumnas.Resize(colsColumnas)
  274. Call Transponer(origenTitulosColumnas, destinoTitulosColumnas)
  275. If opcionFormatear Then
  276. Colorear colorTitulos, colorTitulos, destinoTitulosColumnas
  277. End If
  278.  
  279. 'Títulos de fila
  280. Call Copiar(origenTitulosFilas, destinoTitulosFilas)
  281. Set destinoTitulosFilas = destinoTitulosFilas.Resize(, colsFilas)
  282. If opcionFormatear Then
  283. Colorear colorTitulos, destinoTitulosFilas
  284. End If
  285.  
  286. 'Títulos de Totales
  287. Set destinoTitulosTotal = destinoTotal.Offset(, -1).Resize(, 1)
  288. destinoTitulosTotal.Value = "Total"
  289. If opcionFormatear Then
  290. Colorear colorTitulos, destinoTitulosTotal
  291. destinoTotal.Font.Size = 8
  292. destinoTitulosTotal.Font.Size = 8: destinoTitulosTotal.HorizontalAlignment = xlRight
  293. End If
  294. End If
  295.  
  296.  
  297. 'Acabar de formatear
  298. If opcionFormatear Then
  299. If opcionTitulos Then
  300. destinoTitulosColumnas.Font.Size = 8: destinoTitulosColumnas.HorizontalAlignment = xlRight
  301. destinoTitulosFilas.Font.Size = 8: destinoTitulosFilas.HorizontalAlignment = xlCenter
  302. End If
  303. destinoTitulosDatos.Font.Size = 8: destinoTitulosDatos.HorizontalAlignment = xlCenter
  304.  
  305. Call CebrarFilas(origenColumnas, ColorColumnas)
  306. Call CebrarFilas(origenFilas, ColorFilas)
  307. Call CebrarFilas(origenDatos, ColorDatos)
  308.  
  309. Call CombinarGrupos(destinoColumnas, "FILA", ColorColumnas, opcionCombinar)
  310. Call CombinarGrupos(destinoFilas, "COLUMNA", ColorFilas, opcionCombinar)
  311.  
  312. filas = destinoColumnas.Rows.Count + 1
  313. columnas = destinoFilas.Columns.Count + 0
  314. If opcionCombinar Then
  315. If colsColumnas > 1 Or colsDatos > 1 Then
  316. Call BordearGruposCombinados(destinoDatos.Offset(-filas).Resize(destinoDatos.Rows.Count + filas), "COLUMNA")
  317. End If
  318. If colsFilas > 1 Then
  319. Call BordearGruposCombinados(destinoDatos.Offset(, -columnas).Resize(, destinoDatos.Columns.Count + columnas), "FILA")
  320. End If
  321. Else
  322. If colsColumnas > 1 Or colsDatos > 1 Then
  323. Call BordearGrupos(destinoDatos.Offset(-filas).Resize(destinoDatos.Rows.Count + filas), "COLUMNA")
  324. End If
  325. If colsFilas > 1 Then
  326. Call BordearGrupos(destinoDatos.Offset(, -columnas).Resize(, destinoDatos.Columns.Count + columnas), "FILA")
  327. End If
  328. End If
  329.  
  330. With destinoTitulosDatos.Borders(xlEdgeTop)
  331. .LineStyle = xlContinuous
  332. .Weight = xlThin
  333. .ColorIndex = COLOR_GRIS
  334. End With
  335.  
  336. End If
  337.  
  338. If opcionAjustar Then
  339. Call AutoajustarColumnas(Union(destinoFilas, destinoDatos))
  340. End If
  341.  
  342. 'Fijar títulos
  343. If opcionFijar Then
  344. destinoDatos.Worksheet.Activate
  345. destinoDatos.Cells(1).Activate
  346. ActiveWindow.FreezePanes = False
  347. ActiveWindow.FreezePanes = True
  348. End If
  349.  
  350. 'Crear nombres de rango 2009-V-21
  351. 'destinoDatos.Name = "datos"
  352. 'destinoTotal.Name = "total"
  353. '''etc.
  354.  
  355. 'Finalización
  356. Application.ScreenUpdating = True
  357.  
  358. CrearTablaCartesiana = True
  359.  
  360. End Function
  361.  
  362. Public Function CrearTablaDinamica( _
  363. source As Range, _
  364. colsColumnas As Integer, colsFilas As Integer, colsDatos As Integer, _
  365. Optional ByVal nombreTabla As String = "tabla_dinamica", _
  366. Optional ByVal nombreGrafica As String = "grafica_dinamica" _
  367. ) As String
  368. 'Crea una tabla dinámica y un gráfico dinámico
  369. 'Entrada:
  370. ' Una tabla de agrupación. Las columnas indican niveles de agrupación en detalle
  371. ' creciente. Las últimas columnas son los datos
  372. '
  373. '2009-V-14 <fco@proinf.net>
  374.  
  375. 'Código
  376. Dim cache As PivotCache
  377. Dim pivot As PivotTable
  378. Dim Chart As Chart
  379. Dim etiquetas As Range
  380. Dim celda As Range
  381. Dim contador As Integer
  382. Dim nombre As String
  383. Dim etiqueta As String
  384. Dim orientacion As Integer
  385.  
  386. nombreTabla = NuevoNombreHoja(nombreTabla)
  387. With source.Worksheet
  388. .Visible = xlSheetVisible
  389. .Select
  390. End With
  391.  
  392. Set cache = ActiveWorkbook.PivotCaches.Add( _
  393. SourceType:=xlDatabase, _
  394. SourceData:=source)
  395. Set pivot = cache.CreatePivotTable( _
  396. TableDestination:="", _
  397. TableName:=nombreTabla, _
  398. DefaultVersion:=xlPivotTableVersion10)
  399.  
  400. ActiveSheet.Name = nombreTabla
  401.  
  402. contador = 0
  403. Set etiquetas = source.Resize(1)
  404. orientacion = xlColumnField
  405.  
  406. For Each celda In etiquetas.Cells
  407. nombre = celda.Value
  408. etiqueta = nombre & " "
  409. contador = contador + 1
  410. Select Case orientacion
  411. Case xlColumnField
  412. pivot.PivotFields(nombre).Orientation = orientacion
  413. If contador >= colsColumnas Then
  414. contador = 0
  415. orientacion = xlRowField
  416. End If
  417. Case xlRowField
  418. pivot.PivotFields(nombre).Orientation = orientacion
  419. If contador >= colsFilas Then
  420. contador = 0
  421. orientacion = xlDataField
  422. End If
  423. Case xlDataField
  424. pivot.AddDataField pivot.PivotFields(nombre), etiqueta, xlSum
  425. pivot.PivotFields(etiqueta).NumberFormat = celda.Offset(1).NumberFormat '"#,##0.00"
  426. If contador >= colsDatos Then
  427. Exit For
  428. End If
  429. End Select
  430. Next
  431.  
  432. If pivot.DataFields.Count > 1 Then
  433. pivot.DataPivotField.Orientation = xlColumnField
  434. End If
  435.  
  436. Set Chart = Charts.Add(After:=ActiveSheet)
  437. Chart.SetSourceData source:=Worksheets(nombreTabla).Range("A1")
  438. Chart.Location Where:=xlLocationAsNewSheet
  439. Chart.Name = NuevoNombreHoja(nombreGrafica)
  440.  
  441. CrearTablaDinamica = nombreTabla
  442.  
  443. End Function
  444.  
  445. '------------------------------------------------
  446. ' FUNCIONES AUXILIARES DE LA FUNCIÓN PRINCIPAL
  447. '------------------------------------------------
  448.  
  449. Private Function CopiarDatosCartesianos( _
  450. origenColumnas As Range, destinoColumnas As Range, _
  451. origenFilas As Range, destinoFilas As Range, _
  452. origenDatos As Range, destinoDatos As Range _
  453. ) As Boolean
  454. 'Copia en las posiciones correctas los datos de la tabla origen en la tabla destino
  455. '2009-IV-5
  456.  
  457. Dim origCol As Range, origFil As Range, origDat As Range
  458. Dim destCol As Range, destFil As Range, destDat As Range
  459. Dim dest As Range
  460. Dim cuenta As Integer, maxCuenta As Integer
  461. Dim numFils As Integer, indFil As Integer, fil As Integer
  462. Dim numCols As Integer, indCol As Integer, col As Integer
  463. Dim numDatos As Integer
  464.  
  465. numDatos = origenDatos.Columns.Count
  466.  
  467. Set origCol = origenColumnas.Resize(1)
  468. Set origFil = origenFilas.Resize(1)
  469. Set origDat = origenDatos.Resize(1)
  470.  
  471. Set destCol = destinoColumnas.Resize(, 1)
  472. Set destFil = destinoFilas.Resize(1)
  473. Set destDat = destinoDatos.Resize(1, numDatos)
  474.  
  475. indCol = 1: numCols = destinoColumnas.Columns.Count \ numDatos
  476. indFil = 1: numFils = destinoFilas.Rows.Count
  477.  
  478. maxCuenta = origenDatos.Rows.Count
  479. For cuenta = 1 To maxCuenta
  480.  
  481. 'Buscar la columna desde dónde nos quedamos la vez anterior...
  482. ' El bucle for sirve para controlar que no entremos en un bucle infinito
  483. For col = 1 To numCols
  484. If RangosIguales(origCol, destCol) Then
  485. Exit For
  486. End If
  487. If indCol >= numCols Then
  488. indCol = 1
  489. Set destCol = destinoColumnas.Resize(, 1)
  490. Else
  491. indCol = indCol + 1
  492. Set destCol = destCol.Offset(, numDatos)
  493. End If
  494. Next
  495.  
  496. 'Buscar la fila desde dónde nos quedamos la vez anterior...
  497. ' El bucle for sirve para controlar que no entremos en un bucle infinito
  498. For fil = 1 To numFils
  499. If RangosIguales(origFil, destFil) Then
  500. Exit For
  501. End If
  502. If indFil >= numFils Then
  503. indFil = 1
  504. Set destFil = destinoFilas.Resize(1)
  505. Else
  506. indFil = indFil + 1
  507. Set destFil = destFil.Offset(1)
  508. End If
  509. Next
  510.  
  511. Set dest = destDat.Offset(indFil - 1, (indCol - 1) * numDatos)
  512. '''dest.Select
  513.  
  514. Call Copiar(origDat, dest)
  515.  
  516. Set origCol = origCol.Offset(1)
  517. Set origFil = origFil.Offset(1)
  518. Set origDat = origDat.Offset(1)
  519. Next
  520.  
  521. End Function
  522.  
  523. Private Function Formular( _
  524. datos As Range, _
  525. titulos As Range _
  526. ) As Boolean
  527. 'Calcula las fórmulas pendientes
  528. 'Convierte en fórmulas reales las fórmulas simplificadas.
  529. 'Ej: '=Precio/$Precio significa el precio dividido por el total de precio
  530. ' '=Precio*Cantidad significa el precio por la cantidad
  531. '2009-IV-5 <fco@proinf.net>
  532.  
  533. Dim columna As Range, celda As Range
  534. Dim colDatos As Integer, numColsDatos As Integer
  535. Dim colTitulo As Integer, numColsTitulos As Integer
  536. Dim colFormula As Integer
  537. Dim colRef As Integer, filTotal As Integer
  538. Dim titulo As String
  539. Dim crudo As String, formula As String
  540. Dim ref As String, refTotal As String
  541.  
  542. colFormula = 1
  543. filTotal = datos.Offset(datos.Rows.Count).Cells(1).Row
  544. numColsDatos = datos.Columns.Count
  545. numColsTitulos = titulos.Columns.Count
  546. Set columna = datos.Resize(, 1)
  547.  
  548. For colDatos = 1 To numColsDatos
  549.  
  550. For Each celda In columna
  551. If Left(celda.Value, 1) = "=" Then
  552. If celda.Value <> crudo Then
  553. crudo = celda.Value
  554. formula = crudo
  555. For colTitulo = 1 To numColsTitulos
  556. titulo = titulos.Cells(colTitulo).Value
  557. colRef = colTitulo - colFormula
  558. ref = "RC[" & colRef & "]"
  559. refTotal = "R" & filTotal & "C[" & colRef & "]"
  560. formula = Replace(formula, "$" & titulo, refTotal)
  561. formula = Replace(formula, titulo, ref)
  562. Next
  563. End If
  564. celda.FormulaR1C1 = formula
  565. With celda.Font
  566. .ColorIndex = COLOR_CENIZA
  567. .Size = 8
  568. End With
  569. End If
  570. Next
  571. Set columna = columna.Offset(, 1)
  572. colFormula = colFormula + 1
  573. If colFormula > numColsTitulos Then
  574. colFormula = 1
  575. End If
  576. Next
  577.  
  578. End Function
  579.  
  580.  
  581. Private Function FormatearDatos( _
  582. datos As Range, _
  583. listaFormatos As Variant _
  584. ) As Boolean
  585. 'Formatea las columnas de datos y oculta columnas
  586. '2009-V-21 <fco@proinf.net>
  587.  
  588. Dim DatosConTotales As Range
  589. Dim columna As Range
  590. Dim indice As Integer
  591. Dim cuenta As Integer
  592. Dim fila As Integer
  593. Dim formato As String
  594.  
  595. Set DatosConTotales = datos.Resize(datos.Rows.Count + 1)
  596. Set columna = DatosConTotales.Resize(, 1)
  597.  
  598. indice = 0
  599. For cuenta = 1 To datos.Columns.Count
  600.  
  601. If indice > UBound(listaFormatos) Then
  602. indice = 0
  603. End If
  604. formato = Trim(listaFormatos(indice))
  605.  
  606. Select Case formato
  607. Case "", "-":
  608. 'Nada
  609. Case "H":
  610. columna.EntireColumn.Hidden = True
  611. Case Else:
  612. columna.NumberFormat = formato
  613. End Select
  614.  
  615. Set columna = columna.Offset(, 1)
  616. indice = indice + 1
  617. Next
  618.  
  619. End Function
  620.  
  621. Private Function Copiar(origen As Range, destino As Range) As Boolean
  622. 'Copia el rango origen en el destino.
  623. '2009-IV-1
  624. Call origen.Copy(destino)
  625. End Function
  626.  
  627. Private Function OrdenarFilas(rango As Range) As Boolean
  628. 'Ordena las filas tomando como criterio de ordenación la primera columna,
  629. 'luego la segunda, y así hasta llegar a la última columna.
  630. '
  631. 'Excel sólo puede ordenar por tres campos a la vez.
  632. 'Para solucionar este problema ordenamos por las tres últimas columnas,
  633. ' luego por las siguientes tres columnas a la izquierda de las anteriores
  634. ' y finalmente por las columnas que queden más a la izquierda
  635. 'Ejemplo: call OrdenarFilas (sheets("ordenar").range("m3").currentregion)
  636. '
  637. ' C 1 --> A 2
  638. ' B 3 B 1
  639. ' A 2 B 3
  640. ' B 1 C 1
  641. '
  642. '2009-IV-1 <fco@proinf.net>
  643. '2009-IV-3 Empezar con lo que dé el módulo y luego de tres en tres
  644.  
  645. Dim numCols As Integer
  646. Dim numTriosCompletos As Integer
  647. Dim trio As Integer
  648. Dim restoTrio As Integer
  649. Dim ultimaColumna As Integer
  650.  
  651. numCols = rango.Columns.Count
  652. numTriosCompletos = numCols \ 3
  653. restoTrio = numCols Mod 3
  654. ultimaColumna = numCols
  655.  
  656. Select Case restoTrio
  657. Case 1:
  658. rango.Sort _
  659. key1:=rango.Cells(, ultimaColumna)
  660. Case 2:
  661. rango.Sort _
  662. key1:=rango.Cells(, ultimaColumna - 1), _
  663. key2:=rango.Cells(, ultimaColumna)
  664. End Select
  665. ultimaColumna = ultimaColumna - restoTrio
  666.  
  667. For trio = 1 To numTriosCompletos
  668. rango.Sort _
  669. key1:=rango.Cells(, ultimaColumna - 2), _
  670. key2:=rango.Cells(, ultimaColumna - 1), _
  671. key3:=rango.Cells(, ultimaColumna)
  672. ultimaColumna = ultimaColumna - 3
  673. Next
  674.  
  675. End Function
  676.  
  677. Private Function EliminarFilasDuplicadasConsecutivas(rango As Range) As Integer
  678. 'Borra las filas consecutivos cuyos contenidos sean los mismos.
  679. '
  680. ' A --> A
  681. ' A -
  682. ' A -
  683. ' B B
  684. ' B -
  685. '
  686. '2009-IV-3
  687.  
  688. Dim filaOrigen As Range
  689. Dim filaDestino As Range
  690. Dim numFilas As Integer, fila As Integer
  691. Dim numFilasBorradas As Integer
  692.  
  693. numFilas = rango.Rows.Count
  694. If numFilas > 1 Then
  695. Set filaOrigen = rango.Resize(1)
  696. Set filaDestino = filaOrigen.Offset(1)
  697. For fila = 2 To numFilas
  698. If RangosIguales(filaOrigen, filaDestino) Then
  699. Call Borrar(filaDestino)
  700. numFilasBorradas = numFilasBorradas + 1
  701. Else
  702. Set filaOrigen = filaDestino
  703. End If
  704. Set filaDestino = filaDestino.Offset(1)
  705. Next
  706. End If
  707. EliminarFilasDuplicadasConsecutivas = numFilasBorradas
  708.  
  709. End Function
  710.  
  711. Private Function CompactarFilas(rango As Range) As Boolean
  712. 'Sube las filas inferiores aprovechando los huecos de filas vacías
  713. '
  714. ' A --> A
  715. ' - B
  716. ' -
  717. ' B
  718. ' -
  719. '
  720. '2009-IV-3
  721. On Error Resume Next '2009-IV-16; pasa a la linea siguiente sin mirar el error
  722. rango.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
  723. End Function
  724.  
  725. Private Function DuplicarFilas(rango As Range, veces As Integer) As Boolean
  726. 'Duplica cada fila el número de veces indicado
  727. '
  728. ' A -2-> A A -3-> A
  729. ' B A B A
  730. ' C B A
  731. ' B B
  732. ' C B
  733. ' C B
  734. '
  735. '2009-IV-5
  736.  
  737. Dim cuenta As Integer
  738. Dim numFilas As Integer
  739. Dim origen As Range
  740. Dim destino As Range
  741.  
  742. numFilas = rango.Rows.Count
  743. Set origen = rango.Resize(1).Offset(numFilas)
  744. Set destino = rango.Resize(veces).Offset(numFilas * veces)
  745.  
  746. For cuenta = 1 To numFilas
  747. Set origen = origen.Offset(-1)
  748. Set destino = destino.Offset(-veces)
  749. Call Copiar(origen, destino)
  750. Next
  751.  
  752. End Function
  753.  
  754. Private Function CombinarGrupos( _
  755. rango As Range, _
  756. Optional ByVal tipo As String = "COLUMNA", _
  757. Optional ByVal indiceColorPar As Integer = COLOR_BLANCO, _
  758. Optional ByVal combinar As Boolean = True _
  759. ) As Boolean
  760. 'Combina las celdas consecutivas con el mismo valor que se encuentren
  761. ' dentro de la misma columna o bien dentro de la misma fila según esté
  762. ' indicado en el parámetro tipo
  763. '
  764. ' A A B B B --> A B
  765. ' a b c d e a b c d e
  766. '
  767. '2009-IV-3
  768. '2009-V-12 parámetro combinar
  769.  
  770. Dim numIteraciones As Integer, cuentaIteracion As Integer
  771. Dim numCeldas As Integer, cuentaCelda As Integer
  772. Dim avanceColumna As Integer, avanceFila As Integer
  773. Dim celdaInicio As Range, celdaOrigen As Range, celdaDestino As Range
  774. Dim grupo As Range
  775. Dim esPar As Boolean
  776.  
  777. If tipo <> "COLUMNA" And tipo <> "FILA" Then Exit Function
  778.  
  779. If tipo = "COLUMNA" Then
  780. numIteraciones = rango.Columns.Count
  781. numCeldas = rango.Rows.Count
  782. avanceFila = 1
  783. avanceColumna = 0
  784. ElseIf tipo = "FILA" Then
  785. numIteraciones = rango.Rows.Count
  786. numCeldas = rango.Columns.Count
  787. avanceFila = 0
  788. avanceColumna = 1
  789. End If
  790.  
  791. Set celdaInicio = rango.Cells(1)
  792. For cuentaIteracion = 1 To numIteraciones
  793. Set celdaOrigen = celdaInicio
  794. Set celdaDestino = celdaOrigen.Offset(avanceFila, avanceColumna)
  795. esPar = False
  796. For cuentaCelda = 1 To numCeldas
  797. If cuentaCelda = numCeldas Or celdaOrigen.Value <> celdaDestino.Value Then
  798. Set grupo = Range(celdaOrigen, celdaDestino.Offset(-avanceFila, -avanceColumna))
  799. If esPar Then grupo.Interior.ColorIndex = indiceColorPar
  800. If combinar Then
  801. With grupo
  802. Dim valor As Variant
  803. valor = .Cells(1).Value
  804. .ClearContents
  805. .Merge
  806. .Cells(1).Value = valor
  807. '.BorderAround xlContinuous, xlThin, COLOR_PLOMO
  808. .HorizontalAlignment = xlCenter 'xlLeft 'xlGeneral
  809. .VerticalAlignment = xlTop
  810. End With
  811. Else 'Sin combinar 2009-V-12
  812. Dim celda As Range, celdaPrimera As Range
  813. Dim formula As String
  814. Set celdaPrimera = Nothing
  815. For Each celda In grupo.Cells
  816. If celdaPrimera Is Nothing Then
  817. Set celdaPrimera = celda
  818. formula = "=R" & celdaPrimera.Row & "C" & celdaPrimera.Column
  819. Else
  820. celda.Font.ColorIndex = celda.Interior.ColorIndex
  821. ''formula = "=R[<row>]C[<column>]"
  822. ''formula = Replace(formula, "<row>", celdaPrimera.Row - celda.Row)
  823. ''formula = Replace(formula, "<column>", celdaPrimera.Column - celda.Column)
  824. celda.FormulaR1C1 = formula
  825. End If
  826. Next
  827. End If
  828. esPar = Not esPar
  829. Set celdaOrigen = celdaDestino
  830. End If
  831. Set celdaDestino = celdaDestino.Offset(avanceFila, avanceColumna)
  832. Next
  833. Set celdaInicio = celdaInicio.Offset(avanceColumna, avanceFila)
  834. Next
  835.  
  836. End Function
  837.  
  838. Private Function BordearGruposCombinados( _
  839. rango As Range, _
  840. Optional ByVal tipo As String = "COLUMNA" _
  841. ) As Boolean
  842. 'Bordea los columnas de arriba a abajo o las filas de izquierda a derecha
  843. ' según los datos de la primera fila o primera columna.
  844. 'De esta forma queda remarcado de forma más patente los grupos principales.
  845. '
  846. ' A B --> | A | B |
  847. ' a a b b b |a a|b b b|
  848. '
  849. '2009-IV-5
  850.  
  851. Dim cuenta As Integer, maxCuenta As Integer
  852. Dim amplitud As Integer
  853. Dim grupo As Range
  854.  
  855. If tipo <> "COLUMNA" And tipo <> "FILA" Then Exit Function
  856.  
  857. If tipo = "FILA" Then
  858. maxCuenta = rango.Rows.Count
  859. Set grupo = rango.Resize(1)
  860. rango.Resize(rango.Rows.Count, 1).Font.Bold = True
  861. Else
  862. maxCuenta = rango.Columns.Count
  863. Set grupo = rango.Resize(, 1)
  864. rango.Resize(1, rango.Columns.Count).Font.Bold = True
  865. End If
  866.  
  867. cuenta = 1
  868. Do Until cuenta > maxCuenta
  869. If tipo = "FILA" Then
  870. amplitud = grupo.Cells(1).MergeArea.Rows.Count
  871. Set grupo = grupo.Resize(amplitud)
  872. Else
  873. amplitud = grupo.Cells(1).MergeArea.Columns.Count
  874. Set grupo = grupo.Resize(, amplitud)
  875. End If
  876.  
  877. With grupo
  878. .BorderAround xlContinuous, xlMedium, COLOR_NEGRO
  879. End With
  880.  
  881. cuenta = cuenta + amplitud
  882.  
  883. If tipo = "FILA" Then
  884. Set grupo = grupo.Offset(amplitud)
  885. Else
  886. Set grupo = grupo.Offset(, amplitud)
  887. End If
  888. Loop
  889.  
  890. End Function
  891.  
  892. Private Function BordearGrupos( _
  893. rango As Range, _
  894. Optional ByVal tipo As String = "COLUMNA" _
  895. ) As Boolean
  896. 'Bordea los columnas de arriba a abajo o las filas de izquierda a derecha
  897. ' según los datos de la primera fila o primera columna.
  898. 'De esta forma queda remarcado de forma más patente los grupos principales.
  899. '
  900. ' A A B B B --> |A A|B B B|
  901. ' a a b b b |a a|b b b|
  902. '
  903. '2009-IV-12
  904.  
  905. Dim numCeldas As Integer, cuentaCelda As Integer
  906. Dim avanceColumna As Integer, avanceFila As Integer
  907. Dim celdaOrigen As Range, celdaDestino As Range
  908. Dim grupo As Range
  909. Dim amplitud As Integer
  910.  
  911. If tipo <> "COLUMNA" And tipo <> "FILA" Then Exit Function
  912.  
  913. If tipo = "FILA" Then
  914. numCeldas = rango.Rows.Count
  915. avanceFila = 1: avanceColumna = 0
  916. amplitud = rango.Columns.Count
  917. ElseIf tipo = "COLUMNA" Then
  918. numCeldas = rango.Columns.Count
  919. avanceFila = 0: avanceColumna = 1
  920. amplitud = rango.Rows.Count
  921. End If
  922.  
  923. Set celdaOrigen = rango.Cells(1)
  924. Set celdaDestino = celdaOrigen.Offset(avanceFila, avanceColumna)
  925. For cuentaCelda = 1 To numCeldas
  926. If cuentaCelda = numCeldas Or celdaOrigen.Value <> celdaDestino.Value Then
  927. Set grupo = Range(celdaOrigen, celdaDestino.Offset(-avanceFila, -avanceColumna))
  928. If tipo = "FILA" Then
  929. Set grupo = grupo.Resize(, amplitud)
  930. Else
  931. Set grupo = grupo.Resize(amplitud)
  932. End If
  933.  
  934. With grupo
  935. .BorderAround xlContinuous, xlMedium, COLOR_NEGRO
  936. .Cells(1).Font.Bold = True
  937. End With
  938.  
  939. Set celdaOrigen = celdaDestino
  940. End If
  941. Set celdaDestino = celdaDestino.Offset(avanceFila, avanceColumna)
  942. Next
  943. End Function
  944.  
  945. Private Function Transponer(origen As Range, destino As Range) As Boolean
  946. 'Copia el rango cambiando filas por columnas y viceversa.
  947. '
  948. ' A --> A B C
  949. ' B
  950. ' C
  951. '
  952. '2009-IV-3
  953.  
  954. 'Este método no me gusta porque modifica el contenido del portapapeles de Windows
  955. '''origen.Copy
  956. '''destino.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
  957. '''Application.CutCopyMode = False
  958.  
  959. Dim numFilas As Integer, fila As Integer
  960. Dim numColumnas As Integer, columna As Integer
  961.  
  962. numFilas = origen.Rows.Count
  963. numColumnas = origen.Columns.Count
  964.  
  965. If numFilas >= 256 Then
  966. MsgBox "Hay demasiados datos" & vbCrLf & _
  967. "Una hoja de cálculo no puede tener más de 256 columnas", vbExclamation
  968. Transponer = False
  969. Else
  970. For fila = 1 To numFilas
  971. For columna = 1 To numColumnas
  972. destino.Cells(columna, fila).Value = origen.Cells(fila, columna).Value
  973. Next
  974. Next
  975. Transponer = True
  976. End If
  977.  
  978. End Function
  979.  
  980. Private Function Borrar(rango As Range) As Boolean
  981. 'Elimina el contenido de las celdas.
  982. '2009-IV-3
  983. rango.Clear
  984. End Function
  985.  
  986. Private Function Rellenar(origen As Range, destino As Range) As Boolean
  987. 'Copia N veces el rango origen en el rango destino.
  988. '
  989. ' A B --> A B A B A B ...
  990. '
  991. '2009-IV-3
  992. On Error Resume Next '2009-IV-21
  993. origen.AutoFill Destination:=destino, Type:=xlFillDefault
  994. End Function
  995.  
  996. Private Function RellenarFormato(origen As Range, destino As Range) As Boolean
  997. 'Copia el formato de origen en destino
  998. '2009-IV-5
  999.  
  1000. Dim indDest As Integer, numDest As Integer
  1001. Dim indOrig As Integer, numOrig As Integer
  1002.  
  1003. numOrig = origen.Cells.Count
  1004. numDest = destino.Cells.Count
  1005.  
  1006. indOrig = 1
  1007. For indDest = 1 To numDest
  1008. '''destino.Cells(indDest).Value = 0
  1009. destino.Cells(indDest).NumberFormat = origen.Cells(indOrig).NumberFormat
  1010. indOrig = indOrig + 1
  1011. If indOrig > numOrig Then
  1012. indOrig = 1
  1013. End If
  1014. Next
  1015.  
  1016. End Function
  1017.  
  1018. Private Function Totalizar(origen As Range, destino As Range, listaFormulas As Variant) As Boolean
  1019. 'Crea una fila con el total de cada columna
  1020. '
  1021. 'Parámetro listaFormulas:
  1022. ' Ej.: "S;;A;" significa la 1ºcolumna sumar, la 2ª nada, la 3ª promedio y la 4ª nada
  1023. ' Ej: "S-A-"
  1024. ' Ej: "=SUM(<>);;=AVERAGE(<>);=RC[-1]/RC[-2]"
  1025. ' Abreviaturas: S=suma, A=promedio, -=nada
  1026. '
  1027. '2009-IV-5
  1028.  
  1029. Dim indiceColumna As Integer, numColumnas As Integer
  1030. Dim indiceFormula As Integer
  1031. Dim columna As Range
  1032. Dim celdaFormula As Range
  1033. Dim inicio As Range, fin As Range
  1034. Dim rango As String
  1035. Dim formula As String
  1036.  
  1037. numColumnas = origen.Columns.Count
  1038. Set columna = origen.Resize(, 1)
  1039. Set inicio = columna.Cells(1)
  1040. Set fin = columna.Cells(origen.Rows.Count)
  1041. Set celdaFormula = destino.Resize(1, 1)
  1042.  
  1043. rango = "R[<inicio>]C[<columna>]:R[<fin>]C[<columna>]"
  1044. rango = Replace(rango, "<columna>", inicio.Column - celdaFormula.Column)
  1045. rango = Replace(rango, "<inicio>", inicio.Row - celdaFormula.Row)
  1046. rango = Replace(rango, "<fin>", fin.Row - celdaFormula.Row)
  1047.  
  1048. indiceFormula = LBound(listaFormulas)
  1049. For indiceColumna = 1 To numColumnas
  1050. formula = listaFormulas(indiceFormula)
  1051.  
  1052. Select Case formula 'Alias para las fórmulas
  1053. Case "S": formula = "=SUM(<>)"
  1054. Case "A": formula = "=AVERAGE(<>)"
  1055. End Select
  1056.  
  1057. If formula <> "" Then
  1058. formula = Replace(formula, "<>", rango)
  1059. celdaFormula.NumberFormat = columna.Cells(1).NumberFormat
  1060. If Left(formula, 1) = "=" Then
  1061. celdaFormula.FormulaR1C1 = formula
  1062. Else
  1063. celdaFormula.Value = formula
  1064. End If
  1065. End If
  1066.  
  1067. If indiceFormula = UBound(listaFormulas) Then
  1068. indiceFormula = LBound(listaFormulas)
  1069. Else
  1070. indiceFormula = indiceFormula + 1
  1071. End If
  1072.  
  1073. Set columna = columna.Offset(, 1)
  1074. Set celdaFormula = celdaFormula.Offset(, 1)
  1075. Next
  1076.  
  1077. End Function
  1078.  
  1079. Private Function CrearGraficos( _
  1080. rangoDatos As Range, _
  1081. numColsTitulo As Integer, numFilasTitulo As Integer, numDatos As Integer, _
  1082. ByVal tiposGraficos As Variant _
  1083. ) As Boolean
  1084. 'Crea un gráfico por cada título de datos
  1085. '
  1086. ' +--------------------+
  1087. ' |nºfilasTitulo |
  1088. '+--------------+--------+-----------+
  1089. '| |nºDatos | ... |
  1090. '+--------------+--------+-----------+
  1091. '| nºcolsTitulo | rangoDatos |
  1092. '| | |
  1093. '+--------------+--------------------+
  1094. '
  1095. 'El parámetro "tipos de gráficos" codifica un tipo de gráfico diferente para cada dato:
  1096. ' Ej: "C-S-"
  1097. ' Ej: "C;;S;"
  1098. ' Abreviaturas: C=columnas,S=columnas apiladas,A=área,L=línea,B=barras,P=tarta
  1099. '
  1100. '2009-V-7, 2009-x-5
  1101. On Error GoTo Errores
  1102. Dim rangoEncabezado As Range
  1103. Dim rangoInicialGrafico As Range
  1104. Dim rangoTitulos As Range
  1105. Dim rangoGrafico As Range
  1106. Dim rangoColumna As Range
  1107. Dim celda As Range
  1108. Dim indiceTipo As Integer
  1109. Dim indice As Integer, cuenta As Integer
  1110. Dim grafico As Chart
  1111. Dim tipoGrafico As Variant 'XlChartType
  1112. Dim hojaDelantera As Object
  1113.  
  1114. Set rangoEncabezado = rangoDatos.Offset(-numFilasTitulo - 1).Resize(numFilasTitulo)
  1115.  
  1116. Set rangoInicialGrafico = Union( _
  1117. rangoEncabezado.Resize(, numColsTitulo).Offset(, -numColsTitulo), _
  1118. rangoDatos.Resize(, numColsTitulo).Offset(, -numColsTitulo))
  1119.  
  1120. Set rangoTitulos = rangoDatos.Offset(-1).Resize(1, numDatos)
  1121.  
  1122. Set hojaDelantera = rangoDatos.Worksheet
  1123.  
  1124. indiceTipo = LBound(tiposGraficos)
  1125. cuenta = 1
  1126. For Each celda In rangoTitulos.Cells
  1127.  
  1128. tipoGrafico = tiposGraficos(indiceTipo)
  1129. If Not IsNumeric(tipoGrafico) Then
  1130.  
  1131. 'Alias para los gráficos
  1132. Select Case tiposGraficos(indiceTipo)
  1133. Case "C": tipoGrafico = xlColumnClustered
  1134. Case "S": tipoGrafico = xlColumnStacked
  1135. Case "A": tipoGrafico = xlAreaStacked
  1136. Case "L": tipoGrafico = xlLine
  1137. Case "B": tipoGrafico = xlBarClustered
  1138. Case "P": tipoGrafico = xlPie
  1139. Case Else: tipoGrafico = 0
  1140. End Select
  1141. End If
  1142.  
  1143. If tipoGrafico <> 0 Then
  1144. Set rangoGrafico = rangoInicialGrafico
  1145. For indice = cuenta To rangoDatos.Columns.Count Step numDatos
  1146. Set rangoGrafico = Union(rangoGrafico, _
  1147. rangoEncabezado.Columns(indice), rangoDatos.Columns(indice))
  1148. Next
  1149.  
  1150. Set grafico = Charts.Add(After:=hojaDelantera) '2009-V-12
  1151. Set hojaDelantera = grafico
  1152. With grafico
  1153. .ChartType = tipoGrafico
  1154. .SetSourceData source:=rangoGrafico, PlotBy:=xlRows
  1155. .Location Where:=xlLocationAsNewSheet
  1156. .Name = NuevoNombreHoja("grafico " & celda.Value)
  1157.  
  1158. .HasTitle = True
  1159. .ChartTitle.Characters.Text = celda.Value
  1160. .Axes(xlCategory, xlPrimary).HasTitle = False
  1161. '''.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "equis"
  1162. .Axes(xlValue, xlPrimary).HasTitle = False
  1163. '''.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "ygriega"
  1164. End With
  1165. End If
  1166.  
  1167. If indiceTipo = UBound(tiposGraficos) Then
  1168. indiceTipo = LBound(tiposGraficos)
  1169. Else
  1170. indiceTipo = indiceTipo + 1
  1171. End If
  1172. cuenta = cuenta + 1
  1173. Next
  1174. CrearGraficos = True
  1175. Salida: 'es etiqueta, no variable
  1176. Exit Function
  1177. Errores:
  1178. Select Case Err.Number
  1179. Case 1004: MsgBox "El gráfico tiene demasiados datos a analizar", vbInformation
  1180. Case Else: MsgBox Err.Description, vbCritical, "Error nº" & Err.Number
  1181. End Select
  1182. Resume Salida
  1183. End Function
  1184.  
  1185. Private Function AutoajustarColumnas(rango As Range) As Boolean
  1186. '2009-V-21
  1187.  
  1188. 'Este método no conviene porque muestra las columnas ocultas, las que tienen ancho 0
  1189. '''rango.EntireColumn.AutoFit
  1190.  
  1191. Dim columna As Range
  1192. For Each columna In rango.Columns
  1193. If Not columna.Hidden Then
  1194. columna.EntireColumn.AutoFit
  1195. End If
  1196. Next
  1197.  
  1198. End Function
  1199.  
  1200.  
  1201. '------------------------------------------------
  1202. ' OTRAS AUXILIARES
  1203. '------------------------------------------------
  1204.  
  1205. Private Function RangosIguales(origen As Range, destino As Range) As Boolean
  1206. 'Indica si los contenidos de los dos rangos coinciden
  1207. '2009-IV-3
  1208.  
  1209. Dim celdaOrigen As Range
  1210. Dim celdaDestino As Range
  1211. Dim indiceDestino As Integer
  1212.  
  1213. If origen.Cells.Count = destino.Cells.Count Then
  1214. indiceDestino = 1
  1215. Set celdaDestino = destino.Cells(indiceDestino)
  1216. For Each celdaOrigen In origen.Cells
  1217. If CStr(celdaOrigen.Value) <> CStr(celdaDestino.Value) Then '2009-IV-16
  1218. RangosIguales = False
  1219. Exit Function
  1220. End If
  1221. indiceDestino = indiceDestino + 1
  1222. Set celdaDestino = destino.Cells(indiceDestino)
  1223. Next
  1224. RangosIguales = True
  1225. Else
  1226. RangosIguales = False
  1227. End If
  1228.  
  1229. End Function
  1230.  
  1231. Private Function PatronEnArray(ByVal patron As Variant, ByVal colsDatos As Integer) As Variant
  1232. '2009-V-12
  1233. If Not IsArray(patron) Then
  1234. If patron = "" Then patron = "-"
  1235. If InStr(patron, SEPARADOR_LISTA) Then
  1236. patron = Split(patron, SEPARADOR_LISTA)
  1237. Else
  1238. patron = CaracteresEnArray(UCase(Left(patron & String(colsDatos, Left(patron, 1)), colsDatos)))
  1239. End If
  1240. End If
  1241. PatronEnArray = patron
  1242. End Function
  1243.  
  1244.  
  1245.  
  1246.  

Proinf.net