Saltar al contenido

Crear Macro en excel para generar varias gráficas en una hoja

publicado

Buenas tardes me pueden colaborar con este problemita que tengo:

Tengo que realizar 440 graficos o mas en excel de una tabla.

La macro que tengo los realiza pero en diferentes hojas del libro pero me solicitaron que mejor sea en varias hojas pero en cada hoja esten 50 graficos en dos columnas

la macro que tengo es:

[COLOR=#333333][FONT=arial]Sub principal()[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Dim fila As Integer[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Dim Rango As String, Rango1 As String[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]Range("A3:A3").Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Selection.End(xlDown).Select ' Ubico el último registro de la columna[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Dim b As String[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]b = ActiveWindow.RangeSelection.Row ' Declaro la fí*la como una variable[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]Dim Mensaje, Estilo, Tí*tulo, Respuesta, MiCadena[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Mensaje = "La cantidad de graficos a crear es de: " & b ' Define el mensaje.[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Estilo = vbOKOnly + vbInformation + vbDefaultButton2 ' Define los botones.[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Tí*tulo = "Fila" ' Define el tí*tulo.[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]Respuesta = MsgBox(Mensaje, Estilo, Tí*tulo)[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]fila = 2[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Do[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]' Grafica No 1[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Worksheets("Hoja5").Rows(1).Copy[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Sheets.Add After:=Sheets(Sheets.Count)[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Rows("1").Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveSheet.Paste[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]xxx = ActiveCell.Worksheet.Name[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]Worksheets("Hoja5").Rows(fila).Copy[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Worksheets(xxx).Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Rows(2).Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Selection.PasteSpecial Paste:=xlValues[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]Worksheets(xxx).Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Range("C1:J2").Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveSheet.Shapes.AddChart.Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveChart.ChartType = xlColumnClustered[/FONT][/COLOR]


[COLOR=#333333][FONT=arial]n = Len(xxx)[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]x = Mid(ActiveChart.Name, n + 2, 20)[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveSheet.Shapes(x).IncrementLeft -260.5[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveSheet.Shapes(x).IncrementTop 15.95[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveSheet.Shapes(x).ScaleWidth 1.25, msoFalse, msoScaleFromTopLeft[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveSheet.Shapes(x).ScaleHeight 1.25, msoFalse, msoScaleFromTopLeft[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]'Cambiamos el título del gráfico[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveChart.ChartArea.Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Selection.AutoScaleFont = True[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]With Selection.Font[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Name = "Arial"[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Size = 10[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Strikethrough = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Superscript = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Subscript = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].OutlineFont = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Shadow = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Underline = xlUnderlineStyleNone[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].ColorIndex = xlAutomatic[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Background = xlAutomatic[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]End With[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]With ActiveChart[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].HasTitle = True[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Axes(xlCategory, xlPrimary).HasTitle = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Axes(xlValue, xlPrimary).HasTitle = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]End With[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]'Quitamos la leyenda[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveChart.HasLegend = False[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]'Ponemos tamaño 7 para el eje Y[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveChart.Axes(xlValue).Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Selection.TickLabels.AutoScaleFont = True[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]With Selection.TickLabels.Font[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Size = 7[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Name = "Arial"[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]End With[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]'Ponemos tamaño 7 para el eje X[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveChart.Axes(xlCategory).Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Selection.TickLabels.AutoScaleFont = True[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]With Selection.TickLabels.Font[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Size = 7[/FONT][/COLOR]
[COLOR=#333333][FONT=arial].Name = "Arial"[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]End With[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]'Ponemos el título en negrita[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]ActiveChart.ChartTitle.Select[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Selection.Font.Bold = True[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]fila = fila + 1[/FONT][/COLOR]
[COLOR=#333333][FONT=arial]Loop Until fila > 3[/FONT][/COLOR]

[COLOR=#333333][FONT=arial]End Sub

[/font][/color]

Tabla y Ejemplo de Grafico para foro.rar

Featured Replies

publicado

Hola rubylola,

por favor, prueba así:

Sub Graficar()

    On Error GoTo errGraficar


    Dim rngDatos As Excel.Range
    Dim wshHojaNueva As Excel.Worksheet
    Dim chtGrafNuevo As Excel.ChartObject
    Dim lngDats As Long
    Dim lngDat As Long
    Dim lngFil As Long
    Dim lngCol As Long


    ' Constante que indica el
    ' número de gráficos por hoja
    Const GRAF_POR_HOJA As Long = 50

    ' Constante que indica las filas
    ' que se dejan de espacio para insertar
    ' el gráfico
    Const FILAS_DE_POR_MEDIO As Long = 25

    ' Se carga el rango de datos en la variable rngDatos
    ' Modificar el nombre de la hoja de ser necesario
    With Sheets("Hoja5")
        Set rngDatos = .Range("a1", .Range("j" & .Rows.Count).End(xlUp))
    End With


    ' Se guarda el número de filas con las que se va a trabajar
    ' Se resta uno para descontar el encabezado
    lngDats = rngDatos.Rows.Count - 1


    ' Ya que puede ser un proceso demorado y que puede
    ' afectar la estructura del libro, se le pregunta al
    ' usuario si desea continuar con la macro
    If MsgBox(prompt:="Se van a crear " & _
                      lngDats & _
                      " gráficos." & vbCrLf & _
                      "¿Desea continuar?", _
              Buttons:=vbQuestion + vbYesNo, _
              Title:="Graficar") = vbYes Then



        ' Desactiva la actualización de pantalla
        Application.ScreenUpdating = False



        ' Se inicia el recorrido por cada uno
        ' de los datos del rango de datos. Como se
        ' inicia en la fila 2, se agrega + 1 a la
        ' cantidad de datos.
        For lngDat = 2 To lngDats + 1


            ' Se inserta una nueva hoja y se reinicia el contador de
            ' filas cada vez que se alcance el número de gráficos por hoja
            If Not CBool((lngDat - 2) Mod GRAF_POR_HOJA) Then
                Set wshHojaNueva = Sheets.Add(after:=Sheets(Sheets.Count))
                lngFil = 0
            End If


            ' Muestra un mensaje en la barra de estado para
            ' informar al usuario sobre el avance del trabajo
            Application.StatusBar = "Hoja : " & _
                                    (lngDat - 1) \ GRAF_POR_HOJA + 1 & _
                                    " de " & lngDats \ GRAF_POR_HOJA + 1 & _
                                    " | Dato : " & _
                                    lngDat - 1 & " de " & lngDats

            ' Si es impar, se copian los datos en la columna 1 y se pasa
            ' a la siguiente fila, de lo contrario, se copian en la columna 12
            If CBool((lngDat - 2) Mod 2) Then
                lngCol = 12
            Else
                lngCol = 1
                lngFil = lngFil + 1
            End If


            ' Se copian los datos en la hoja, fila y columna indicada
            rngDatos.Rows(1).Copy wshHojaNueva.Cells(lngFil * FILAS_DE_POR_MEDIO - FILAS_DE_POR_MEDIO + 1, lngCol)
            rngDatos.Rows(lngDat).Copy wshHojaNueva.Cells(lngFil * FILAS_DE_POR_MEDIO - FILAS_DE_POR_MEDIO + 2, lngCol)


            ' Se crea un nuevo gráfico para la hoja, fila y columna indicada
            With wshHojaNueva


                ' Se inserta el gráfico en la posición deseada y es asignado a la variable chtGrafNuevo
                Set chtGrafNuevo = .ChartObjects.Add(Left:=.Cells(lngFil * FILAS_DE_POR_MEDIO - FILAS_DE_POR_MEDIO + 4, lngCol + 1).Left, _
                                                     Top:=.Cells(lngFil * FILAS_DE_POR_MEDIO - FILAS_DE_POR_MEDIO + 4, lngCol).Top, _
                                                     Width:=379, _
                                                     Height:=265)

                ' Datos que alimentan al gráfico chtGrafNuevo
                chtGrafNuevo.Chart.SetSourceData Source:=wshHojaNueva.Cells(lngFil * FILAS_DE_POR_MEDIO - FILAS_DE_POR_MEDIO + 1, lngCol + 2).Resize(2, 8)


                ' Se formatea el gráfico chtGrafNuevo de acuerdo con lo deseado
                FormatearGraf chtGrafNuevo


            End With

        Next lngDat

    End If


    ' Si todo ha salido bien...
    MsgBox prompt:="¡Uffff! Parece que todo ha salido bien.", _
           Buttons:=vbExclamation, _
           Title:="Graficar"


exitGraficar:

    Set rngDatos = Nothing
    Set wshHojaNueva = Nothing
    Set chtGrafNuevo = Nothing

    Application.StatusBar = False
    Application.ScreenUpdating = True

    Exit Sub


errGraficar:
    MsgBox prompt:="!Carajo! Algo ha salido mal." & _
                   vbCrLf & vbCrLf & _
                   "Error " & Err.Number & ": " & Err.Description, _
           Buttons:=vbCritical, _
           Title:=Err.Source

    Resume exitGraficar


End Sub
Public Sub FormatearGraf(ByRef Graf As Excel.ChartObject)

    With Graf.Chart

        ' Título en negrita
        .ChartTitle.Font.Bold = True

        ' Quita la leyenda
        .HasLegend = False

        With .ChartArea

            ' Letra tamaño 10 y fuenta Arial
            ' para el area del gráfico
            With .Font
                .Name = "Arial"
                .Size = 10
            End With

        End With


        ' Letra tamaño 7 y fuenta Arial para el eje Y
        With .Axes(xlValue).TickLabels.Font
            .Size = 7
            .Name = "Arial"
        End With


        ' Letra tamaño 7 y fuenta Arial para el eje X
        With .Axes(xlCategory).TickLabels.Font
            .Size = 7
            .Name = "Arial"
        End With


    End With


End Sub

Fíjate que he dejado la rutina FormatearGraf aparte por si necesitas aplicar en algún momento el formato que quieres, la puedes llamar con algo como:

formateargraf activesheet.chartobjects("[COLOR=#ff0000]Gráfico 1[/COLOR]")

En donde Gráfico 1 es el nombre del gráfico al que le quieres dar el formato.

Fíjate, por favor, en las constantes al inicio del código. Lo he comentado ampliamente para que no tengas problema en modificarlo.

Adjunto la macro en el archivo de muestra que proporcionaste.

Tabla y Ejemplo de Grafico para foro.zip

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Ir al listado de temas