从数据透视表快速创建图表

时间:2014-06-26 14:16:21

标签: excel excel-vba vba

我有以下代码:

Private Sub PivGraphMaker1(ByVal shtnm As String, ByVal src1 As String, ByVal chrtnm As String)

    Application.StatusBar = "Making graph 1."

    Sheets(shtnm).Select

    Range("O1").Select
    ActiveSheet.Shapes.AddChart.Select
    ActiveChart.ChartType = xlColumnClustered
    ActiveChart.SetSourceData Source:=Range(src1)
    ActiveChart.Parent.Name = chrtnm
    ActiveChart.Legend.Select
    Selection.Delete
    ActiveSheet.ChartObjects(chrtnm).Activate
    ActiveChart.SeriesCollection(1).Select
    Selection.Format.Fill.Visible = msoFalse
    ActiveChart.SeriesCollection(1).ApplyDataLabels
    ActiveChart.SeriesCollection(1).DataLabels.Select
    Selection.Position = xlLabelPositionInsideEnd
    ActiveChart.ChartArea.Select
    ActiveChart.SetElement (msoElementChartTitleAboveChart)
    ActiveChart.ChartTitle.Text = "DownTime by Fault Message"
    Selection.Format.TextFrame2.TextRange.Characters.Text = _
        "DownTime by Fault Message"
    With Selection.Format.TextFrame2.TextRange.Characters(1, 25).ParagraphFormat
        .TextDirection = msoTextDirectionLeftToRight
        .Alignment = msoAlignCenter
    End With
    With Selection.Format.TextFrame2.TextRange.Characters(1, 17).Font
        .BaselineOffset = 0
        .Bold = msoTrue
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = RGB(0, 0, 0)
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 18
        .Italic = msoFalse
        .Kerning = 12
        .Name = "+mn-lt"
        .UnderlineStyle = msoNoUnderline
        .Strike = msoNoStrike
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
    ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "Duration in Minutes"
    Selection.Format.TextFrame2.TextRange.Characters.Text = "Duration in Minutes"
    With Selection.Format.TextFrame2.TextRange.Characters(1, 19).ParagraphFormat
        .TextDirection = msoTextDirectionLeftToRight
        .Alignment = msoAlignCenter
    End With
    With Selection.Format.TextFrame2.TextRange.Characters(1, 19).Font
        .BaselineOffset = 0
        .Bold = msoTrue
        .NameComplexScript = "+mn-cs"
        .NameFarEast = "+mn-ea"
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = RGB(0, 0, 0)
        .Fill.Transparency = 0
        .Fill.Solid
        .Size = 10
        .Italic = msoFalse
        .Kerning = 12
        .Name = "+mn-lt"
        .UnderlineStyle = msoNoUnderline
        .Strike = msoNoStrike
    End With
    ActiveChart.ChartArea.Select
    ActiveChart.ChartTitle.Text = shtnm & " DownTime by Fault Message"
    ActiveChart.ChartArea.Select
    ActiveChart.Location Where:=xlLocationAsNewSheet
    ActiveSheet.Name = shtnm & " Faults"
    Application.PrintCommunication = False
    With ActiveChart.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.7)
        .RightMargin = Application.InchesToPoints(0.7)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .ChartSize = xlScreenSize
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
        .PaperSize = xlPaperTabloid
        .FirstPageNumber = xlAutomatic
        .BlackAndWhite = False
        .Zoom = 100
    End With
    Application.PrintCommunication = True

End Sub

代码确实有效。我的问题是 - 所有那些行必要?有了这个,我能做些什么来加速代码(会减少不必要的行帮助)?

要回答几条评论我知道会来 - 我的电脑确实速度慢且动力不足,所以我注意到运行时速度方面的细微变化。我还有像screenupdating和事件禁用的东西。

让我知道我能做些什么!

1 个答案:

答案 0 :(得分:1)

像这样(发码):

Private Sub PivGraphMaker1(ByVal shtnm As String, ByVal src1 As String, ByVal chrtnm As String)
    Dim cht As Excel.Chart
    Application.StatusBar = "Making graph 1."

    Sheets(shtnm).Select
    Range(src1).Select
    Set cht = Charts.Add
    With cht
        .ChartType = xlColumnClustered
        .SetSourceData Source:=Range(src1)
        .Name = shtnm & " faults"
        .HasLegend = False

        With .SeriesCollection(1)
            .Format.Fill.Visible = msoFalse
            .ApplyDataLabels
            .DataLabels.Position = xlLabelPositionInsideEnd
        End With

        .SetElement msoElementChartTitleAboveChart

        With .ChartTitle
            .Text = shtnm & " DownTime by Fault Message"
            With .Format.TextFrame2.TextRange.Characters.ParagraphFormat
                .TextDirection = msoTextDirectionLeftToRight
                .Alignment = msoAlignCenter
            End With
            With .Format.TextFrame2.TextRange.Characters(1, 17).Font
                .Bold = msoTrue
                .Size = 18
                .Kerning = 12
            End With
        End With

        .SetElement msoElementPrimaryValueAxisTitleRotated
        With .Axes(xlValue, xlPrimary).AxisTitle
            .Text = "Duration in Minutes"
            With .Format.TextFrame2.TextRange.Characters(1, 19)
                .ParagraphFormat
                With .Font
                    .Bold = msoTrue
                    .Size = 10
                    .Kerning = 12
                End With
            End With
        End With

        Application.PrintCommunication = False
        With .PageSetup
            .Orientation = xlLandscape
            .PaperSize = xlPaperTabloid
        End With
        Application.PrintCommunication = True
    End With
    Application.StatusBar = False
End Sub