Saltar al contenido
Te enseño 7 de los trucos que me permitieron trabajar 2 horas menos al día >>>

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

rubylola

Recommended Posts

rubylola Novato

rubylola

publicado
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

Enlace a comentario
Compartir con otras webs
mjrofra Novato

mjrofra

publicado
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

Enlace a comentario
Compartir con otras webs

Archivado

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

Ir al listado de temas

  • 96 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • Sí
      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Mantenimiento de la comunidad
      Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR

  • Archivos

  • Estadísticas de descargas

    • Archivos
      177
    • Comentarios
      90
    • Revisiones
      27

  • Crear macros Excel

  • Mensajes

    • daren
      Hacer formulas auto incrementales

      Por daren · publicado

      Buenas noches quisiera hacer esta formula auto incremental    =SI(INDIRECTO("'Casos de Prueba'!I1")="Resultados Ciclo 1"; SI(CONTAR.SI(INDIRECTO("'Casos de Prueba'!I:I"); "OK")=0; 0; CONTAR.SI(INDIRECTO("'Casos de Prueba'!I:I"); "OK")); 0)      para que cada vez que copiase y pegase la celda con la formula  se incrementara la letra en este caso la I pasara a J ,como el numero perteneciente a Resultados Ciclo pasando en este caso del 1 al 2.   Tengo también esta formula =CONCATENAR("CP";TEXTO(MAX((SI((ESNUMERO(HALLAR("CP";A$1:A1)))*(A$1:A1<>"");VALOR(EXTRAE(A$1:A1;3;3));0))+1);"000")&" - "&B2) quisiera que no tuviera los 3 ceros si no que fuera por ejemplo CP1 y se fuera incrementando. Gracias un saludo.
    • Israel Cassales
      Hacer una operación usando una tabla de configuración

      Por Israel Cassales · publicado

      Con el diseño así como lo tiene en su libro, una fórmula de BUSCARV con COINCIDIR debería ser de utilidad =C5*BUSCARV($C$1,Tabla1[#Todo],COINCIDIR($D5,Tabla1[#Encabezados],0)) Es con lo que participaría en su consulta. Lo que resta es definir que hacer si no encuentra la OT porque así como esta le devolvería error en ese caso, o si tiene condiciones que haya podido omitir también le afectarían el resultado.
    • MarianoCruz
      avanzar una celda hacia abajo apartir de una celda seleccionada

      Por MarianoCruz · publicado

      He cambiado mi macro a este: Sub repetir() Set a = Sheets(ActiveSheet.Name) uf = a.Range("C" & Rows.Count).End(xlUp).Row 'ultima fila con datos ActiveCell.Select ActiveCell.Offset(1, 0).Select   'Application.OnTime Now + TimeValue("00:00:10"), "repetir", , True End If End Sub   Lo que no se es como detenerlo al llegar a la ultima fila con datos de la columna C. Muchas gracias
    • Pirtrafilla
      Hacer una operación usando una tabla de configuración

      Por Pirtrafilla · publicado

      Buenas tardes a todos. Tengo un problema que preciso de vuestra ayuda.  Tengo que controlar los gastos de la oficina que trabajo y he de repartir unos gastos a % según una OT y unos tipos de gastos. Envío un archivo adjunto. Lo que necesito es que lo que aparece en la columna en amarillo lo haga automáticamente, teniendo en cuenta los datos de la tabla a la derecha. Por ejemplo, el primer gasto tiene una cuota de 1477 euros y teniendo en cuenta que es un gasto de tipo Común y que la OT es la 12810234, le corresponde un gasto de 605,57 euros ya que según la tabla de la derecha su % a imputar es de un 41%. ¿alguien me puede ayudar con la formula? He de añadir muchas más líneas y más hojas con el resto de OT y en el futuro cambiar más datos, así que necesito automatizarlo con una formula Excel. Gracias. Control de gastos.xlsx
    • MarianoCruz
      avanzar una celda hacia abajo apartir de una celda seleccionada

      Por MarianoCruz · publicado

      Hola buenas tardes: Por favor me pueden ayudar a realizar lo siguiente. ejecutar una macro después de un tiempo, que recorra una columna a partir de la celda activa hacia abajo. Es una lista extensa, que filtro desde la columna B. y solo me muestra las filas que me interesan. ejemplo: Si mi celda activa es la C23 ejecutar la macro y baje una celda y repite la macro después de 20 segundos y lo vuelve hacer(Simpre bajando una celda), y que este se detenga hasta la ultima fila que este visible en el filtro. Ya que puedo tener muchos datos mas.   Gracias   Prueba filtro y avance.xlsm

  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.