VBA--图表

VBA–图表

1.图表复制

Sub CloneLoss()
    Sheets("Loss").Select
    CloneChart 1, "I1", "Loss: WSS1 Med", "dLoss_XXX"
    ActiveSheet.HPageBreaks.Add Before:=Rows(54)
    ActiveSheet.PageSetup.PrintArea = "$A$1:$X$54"
End Sub

Sub CloneChart(ch As Integer, dest As String, capt As String, sh As String)
    ActiveSheet.ChartObjects(ch).Activate
    Sleep 1000
    ActiveChart.ChartArea.Copy
    Range(dest).Select
    Sleep 1000
    ActiveSheet.Paste
    ActiveChart.ChartTitle.Select
    Selection.Caption = capt
    ActiveChart.SetSourceData Source:=Sheets(sh).Range("A1:AQ105")
End Sub

2.图表删除

保留第一个图表，删除余下所有的图表。

Sub DeleteLoss()
    Sheets("Loss").Select
    For i = 2 To ActiveSheet.ChartObjects.Count
        ActiveSheet.ChartObjects(2).Delete
    Next i
End Sub

3.更新X轴刻度

Sub Scale_X_Plots(min As Double, max As Double)
    Scale_X_Plot "Loss", 1, min, max
End Sub

Sub Scale_X_Plot(act_sh As String, ch As Integer, min As Double, max As Double)
    With Sheets(act_sh).ChartObjects(ch).Chart
      .Axes(xlCategory).MinimumScaleIsAuto = False
      .Axes(xlCategory).MinimumScale = min
      .Axes(xlCategory).MaximumScaleIsAuto = False
      .Axes(xlCategory).MaximumScale = max
   End With
End Sub

4.更新Y轴刻度

Sub Scale_Y_BW()
    Scale_Y_Plot "Loss", 1, -4, 4
End Sub

Sub Scale_Y_Plot(act_sh As String, ch As Integer, min As Double, max As Double)
    With Sheets(act_sh).ChartObjects(ch).Chart
      .Axes(xlValue).MinimumScaleIsAuto = False
      .Axes(xlValue).MinimumScale = min
      .Axes(xlValue).MaximumScaleIsAuto = False
      .Axes(xlValue).MaximumScale = max
   End With
End Sub

5.批量清理指定sheet数据

Sub BlowAwayData()
    Dim WS_Count As Integer
    Dim i As Integer
    For i = 1 To ActiveWorkbook.Worksheets.Count
        Dim sMatch As Boolean
        sMatch = ActiveWorkbook.Worksheets(i).Name Like "d*"
        If sMatch Then
            ClearDataSheet (ActiveWorkbook.Worksheets(i).Name)
        End If
    Next i
End Sub

Sub ClearDataSheet(sh As String)
    Sheets(sh).Select
    Range("A1:DZ200").Clear
End Sub

6.图表关联数据

Sub PrepAllCharts()
    Sheets("Loss").Select
    PrepChart 1, "dLoss_1"
    PrepChart 2, "dLoss_2"
    PrepChart 3, "dLoss_3"
    
    Sheets("Atten").Select
    PrepChart 1, "dAtten"
End Sub

Sub PrepChart(ch As Integer, sh As String)
    ActiveSheet.ChartObjects(ch).Activate
    ActiveChart.SetSourceData Source:=Sheets(sh).Range("A1:AQ105")
    
    ActiveChart.Legend.Select
    Selection.Delete
    
    ActiveSheet.ChartObjects(ch).Activate
    ActiveChart.SetElement (msoElementLegendRight)

    Dim tTheme As OfficeTheme
    Dim tcsThemeColorScheme As ThemeColorScheme
    
    ActiveChart.Legend.Select
    Dim j As Integer
    Dim i As Integer
    For j = 0 To 5
	    For i = 1 To 7
	        ActiveChart.SeriesCollection(i + 7 * j).Select
	        With Selection.Format.Line
	            .Visible = msoTrue
	            .ForeColor.ObjectThemeColor = i + 3
	            .ForeColor.TintAndShade = 0
	            .ForeColor.Brightness = -0.5 + 0.3 * j
	            .Transparency = 0
	        End With
	    Next i
    Next j
    
    For i = 35 To 42
      ActiveChart.SeriesCollection(i).Select
      With Selection.Format.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
      End With
    Next i
    
    For i = 42 To 37 Step -1
      ActiveChart.Legend.Select
      ActiveChart.Legend.LegendEntries(i).Select
      Selection.Delete
    Next i
      
    Size_Legend
End Sub

Sub Size_Legend()
    ActiveChart.Legend.Select
    With Selection.Format.TextFrame2.TextRange.Font
        .BaselineOffset = 0
        .Size = 6
    End With
    Selection.Top = 4
    Selection.Left = 350
    Selection.Width = 60
    Selection.Height = 270
End Sub

7.增加Sheet表

Sub AddSheets()
    AddNewSheet "XXX1"
    AddNewSheet "XXX2"
    AddNewSheet "XXX3"
End Sub

Sub AddNewSheet(sh_name As String)
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = sh_name
End Sub