Excel-VBA-批量自动制图表实例集锦.doc

1, 自动生成图表 /thread-1058346-1-1.html统计报告0925a.xls 2013-9-25Sub lqxs()Dim Arr, ks, js, nm1$, nm2$, dz1$, dz2$Dim dz$, dz3$, yy$, nm$Application.ScreenUpdating = FalseSheet3.ActivateArr = a1.CurrentRegionks = 3: js = UBound(Arr) - 1 nm = Sheet3.Name yy = Left(nm, Len(nm) - 3) nm1 = 图表 6 nm2 = 图表 4 dz = A2:B & js & ,D2:E & js ActiveSheet.ChartObjects(nm1).Activate With ActiveChart .SetSourceData Source:=Sheets(nm).Range(dz), PlotBy:=xlColumns .SeriesCollection(1).Select dz1 = R3C2:R & js & C2 .SeriesCollection(1).Values = = & nm & ! & dz1 dz2 = R3C4:R & js & C4 .SeriesCollection(2).Values = = & nm & ! & dz2 dz3 = R3C5:R & js & C5 .SeriesCollection(3).Values = = & nm & ! & dz3 .ChartTitle.Select Selection.Characters.Text = yy & 月份合格率 End With ActiveSheet.ChartObjects(nm2).Activate With ActiveChart .ChartArea.Select dz = H2:T2,H & js + 1 & :T & js + 1 .SetSourceData Source:=Sheets(nm).Range(dz), PlotBy:= _ xlRows dz2 = R & js + 1 & C8:R & js + 1 & C20 .SeriesCollection(1).Values = = & nm & ! & dz2 .ChartTitle.Select Selection.Characters.Text = yy & 月份不良趋势统计 End WithRange(A & ks).SelectApplication.ScreenUpdating = TrueMsgBox OKEnd Sub2, 批量插入图表 2010-9-27批量绘图表.xlsSub ChartsAdd() Dim myChart As ChartObject Dim i As Integer Dim R As Integer Dim m As Integer R = Sheet1.Range(A65536).End(xlUp).Row - 1 m = Abs(Int(-(R / 4) Sheet2.ChartObjects.Delete For i = 1 To R Set myChart = Sheet2.ChartObjects.Add _ (Left:=(i - 1) Mod m) + 1) * 350 - 320, _ Top:=(i - 1) m + 1) * 220 - 210, _ Width:=330, Height:=210) With myChart.Chart .ChartType = xlColumnClustered .SetSourceData Source:=Sheet1.Range(B2:M2).Offset(i - 1), _ PlotBy:=xlRows With .SeriesCollection(1) .XValues = Sheet1.Range(B1:M1) .Name = Sheet1.Range(A2).Offset(i - 1) .ApplyDataLabels AutoText:=True, ShowValue:=True .DataLabels.Font.Size = 10 End With .HasLegend = False With .ChartTitle .Left = 5 .Top = 1 .Font.Size = 14 .Font.Name = 华文行楷 End With With .PlotArea.Interior .ColorIndex = 2 .PatternColorIndex = 1 .Pattern = xlSolid End With .Axes(xlCategory).TickLabels.Font.Size = 10 .Axes(xlValue).TickLabels.Font.Size = 10 End With Next Sheet2.Select Set myChart = NothingEnd Sub3, 批量插入图表 2013-9-30/forum.php?mod=viewthread&tid=1059674&page=1#pid7221588Sub OpenFiles()Dim myX As RangeDim myY As RangeDim i%, j&Application.ScreenUpdating = FalseActiveSheet.ChartObjects(图表 1).ActivateFor i = 1 To ActiveChart.SeriesCollection.Count 序列集合对象的用法 ActiveChart.SeriesCollection(i).Delete 删除原有的序列NextWith ActiveChart.Axes(xlCategory) .MaximumScale = 100 .MinimumScale = 0 .MajorUnit = 20 .MinorUnit = 4End WithWith ActiveChart .ChartType = xlXYScatterLinesNoMarkers 散点图 For i = 1 To Sheet1.Range(IV1).End(xlToLeft).Column + 1 Step 2 j = Sheet1.Range(A65536).Offset(0, i - 1).End(xlUp).Row Set myX = Sheet1.Cells(4, i).Resize(j - 3, 1) Set myY = myX.Offset(0, 1) With .SeriesCollection.NewSeries .Values = myY .XValues = myX .Name = Sheet1.Cells(1, i).Value 序列名 .MarkerStyle = -4142 没有标志显示 End With Next iEnd Witha1.SelectApplication.ScreenUpdating = TrueEnd Sub4, 图表对象 您可以结合使用 Add 方法和 ChartWizard 方法，添加包含工作表数据的新图表。本示例将基于名为 Sheet1 的工作表上单元格 A1:A20 中的数据添加一个新的折线图。With Charts.Add .ChartWizard source:=Worksheets(Sheet1).Range(A1:A20), _ Gallery:=xlLine, Title:=February DataEnd WithChartObject 对象充当 Chart 对象的容器。ChartObject 对象的属性和方法控制工作表上嵌入图表的外观和大小。ChartObject 对象是 ChartObjects 集合的成员。ChartObjects 集合包含单一工作表上的所有嵌入图表。使用 ChartObjects(index)（其中 index 是嵌入图表的索引号或名称）可以返回单个 ChartObject 对象。示例以下示例设置名为“Sheet1”的工作表上嵌入图表 Chart 1 中的图表区图案。Worksheets(Sheet1).ChartObjects(1).Chart. _ ChartArea.Format.Fill.Pattern = msoPatternLightDownwardDiagonal 当选定嵌入图表时，其名称显示在“名称”框中。使用 Name 属性可设置或返回 ChartObject 对象的名称。以下示例对工作表“Sheet1”上的嵌入图表“Chart 1”使用了圆角。Worksheets(sheet1).ChartObjects(chart 1).RoundedCorners = True 5, 保持图表位置居中 by:Lee18922013-12-03Private Sub KeepSquare() Dim dXDiff#, dYDiff#, dDiff# Dim dXMin#, dXMax#, dYMin#, dYMax# With ChartObjects(1).Chart With .Axes(xlCategory) .MaximumScaleIsAuto = True .MinimumScaleIsAuto = True dXMax = .MaximumScale: dXMin = .MinimumScale dXDiff = dXMax - dXMin End With With .Axes(xlValue) .MaximumScaleIsAuto = True .MinimumScaleIsAuto = True dYMax = .MaximumScale: dYMin = .MinimumScale dYDiff = dYMax - dYMin End With dDiff = dXDiff If dXDiff dYDiff Then dDiff = dYDiff With .Axes(xlCategory) .MaximumScale = dXMax + (dDiff - dXDiff) / 2 .MinimumScale = dXMin - (dDiff - dXDiff) / 2 End With With .Axes(xlValue) .MaximumScale = dYMax + (dDiff - dYDiff) / 2 .MinimumScale = dYMin - (dDiff - dYDiff) / 2 End With End WithEnd Sub6, 分表，修改数据序列公式 /thread-1100811-1-1.htmlSub lqxs()Dim Sht As Worksheet, Sht1 As WorksheetDim Arr, i&, r%, Arr1(), ks, js, nm$Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet Sht1 = Sheets(源表)Sht1.ActivateFor Each Sht In Sheets If Sht.Name Sht1.Name Then Sht.DeleteNext ShtArr = a1.CurrentRegionFor i = 3 To UBound(Arr) If Arr(i, 1) Then r = r + 1 ReDim Preserve Arr1(1 To r) Arr1(r) = i End IfNextFor i = 1 To r If i r Then js = Arr1(i + 1) - 1 Else js = UBound(Arr) End If ks = Arr1(i) Sht1.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = Arr(ks, 1) a3:e500.ClearContents Sht1.Cells(ks, 1).Resize(js - ks + 1, 5).Copy a3 nm = Arr(ks, 1) ActiveSheet.ChartObjects(1).Activate With ActiveChart .SetSourceData Source:=Sheets(nm).Range(dz), PlotBy:=xlColumns .FullSeriesCollection(1).Select Selection.Formula = =SERIES( & nm & !R2C4, & nm & !R3C1:R & js - ks + 3 & C2, & nm & !R3C4:R & js - ks + 3 & C4,1) .FullSeriesCollection(2).Select Selection.Formula = =SERIES( & nm & !R2C5, & nm & !R3C1:R & js - ks + 3 & C2, & nm & !R3C5:R & js - ks + 3 & C5,2) .FullSeriesCollection(3).Delete .FullSeriesCollection(3).Delete End WithNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub7, 自动制作多图表 /thread-919757-1-1.html2012-9-13Sub ChartsAdd() Dim myChart As ChartObject Dim i As Integer Dim R As Integer R = Int(Sheet1.Range(A65536).End(xlUp).Row - 1) / 20 ActiveSheet.ChartObjects.Delete For i = 1 To R Set myChart = Sheet1.ChartObjects.Add _ (Left:=200, _ Top:=(i - 1) * 260 + 20, _ Width:=330, Height:=210) With myChart.Chart .ChartType = xlColumnClustered .SetSourceData Source:=Cells(20 * i - 18, 1).Resize(20, 2) End With Next Set myChart = NothingEnd Sub2014-5-4/thread-1118085-1-1.htmlSub ChartsAdd() Dim myChart As ChartObject Dim Myc%, i& On Error Resume Next Myc = iv3.End(xlToLeft).Column nm = ActiveSheet.Name ActiveSheet.ChartObjects.Delete For i = 1 To Myc Step 8 Set myChart = ActiveSheet.ChartObjects.Add _ (Left:=Cells(3, i).Left, _ Top:=Cells(3, i).Top, _ Width:=Cells(3, i).Resize(1, 7).Width, Height:=Cells(3, i).Resize(16, 1).Height) With myChart.Chart .ChartType = xlXYScatterLinesNoMarkers 散点图 .SetSourceData Source:=Cells(550, i + 1).Resize(1351, 2) End With myChart.Activate With ActiveChart .FullSeriesCollection(1).Select .FullSeriesCollection(1).XValues = = & nm & ! & Cells(550, i + 2).Resize(1351, 1).Address .FullSeriesCollection(1).Values = = & nm & ! & Cells(550, i + 1).Resize(1351, 1).Address .FullSeriesCollection(1).Name = = & nm & ! & Cells(2, i + 1).Address .SeriesCollection.NewSeries .FullSeriesCollection(2).XValues = = & nm & ! & Cells(550, i + 6).Resize(1351, 1).Address .FullSeriesCollection(2).Values = = & nm & ! & Cells(550, i + 5).Resize(1351, 1).Address .FullSeriesCollection(2).Name = = & nm & ! & Cells(2, i + 5).Address .Axes(xlValue).MaximumScale = 500 .Axes(xlValue).MinimumScale = -200 .Axes(xlValue).MajorUnit = 100 .Axes(xlValue).MinorUnit = 20.2 .Axes(xlCategory).MinimumScale = -0.000005 .Axes(xlCategory).MaximumScale = 0.00003 .Axes(xlCategory).MajorUnit = 0.000005 .Axes(xlCategory).MinorUnit = 0.000001 .Legend.Position = xlBottom .SetElement (msoElementChartTitleAboveChart) .ChartTitle.Text = Cells(1, i).Value With .ChartTitle.Format.TextFrame2.TextRange.Font .Size = 14 End With End With Next Set myChart = NothingEnd Sub8, 自动生成图表 2014-8-5/thread-1142829-1-1.htmlSub lqxs() Dim Myr&, bt$ Myr = Cells(Rows.Count, 1).End(xlUp).Row ActiveSheet.ChartObjects.Delete ActiveSheet.ChartObjects.Add Left:=g3.Left, _ Top:=g3.Top, _ Width:=g3.Resize(1, 7).Width, Height:=g3.Resize(16, 1).Height ActiveSheet.ChartObjects(1).Activate With ActiveChart .ChartType = xlXYScatterSmoothNoMarkers .SetSourceData Source:=Sheets(CHART).Range(A3:B & Myr), PlotBy _ :=xlColumns .SeriesCollection.NewSeries .SeriesCollection(1).XValues = =CHART!R3C4:R & Myr & C4 .SeriesCollection(1).Values = =CHART!R3C2:R & Myr & C2 .SeriesCollection(1).Name = =CHART!R2C2 .SeriesCollection(2).XValues = =CHART!R3C4:R & Myr & C4 .SeriesCollection(2).Values = =CHART!R3C1:R & Myr & C1 .SeriesCollection(2).Name = =CHART!R2C1 .HasTitle = True: bt = ActiveSheet.TextBox1.Text .ChartTitle.Characters.Text = bt .Axes(xlCategory, xlPrimary).HasTitle = True .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = ActiveSheet.ComboBox2.Text .Axes(xlValue, xlPrimary).HasTitle = True .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = ActiveSheet.ComboBox1.Text .Axes(xlValue).MajorUnit = 1 .ChartTitle.Select With Selection.Font .FontStyle = 加粗 .Size = 18 End With .PlotArea.Select With Selection.Border .Weight = xlThin .LineStyle = xlNone End With Selection.Interior.ColorIndex = xlNone End With Range(a1).SelectEnd Sub9, 自动制作多图表 2014-9-28/thread-1155286-1-1.htmlSub lqxs()Dim myChart As ChartObject, Arr, i&, mx, mn, lfActiveSheet.ChartObjects.DeleteArr = a1.CurrentRegionFor i = 1 To UBound(Arr, 2) lf = Cells(1, UBound(Arr, 2) + 2).Left mx = Application.Max(Cells(1, i).Resize(UBound(Arr), 1) mn = Application.Min(Cells(1, i).Resize(UBound(Arr), 1) Set myChart = ActiveSheet.ChartObjects.Add _ (Left:=lf, Top:=(i - 1) * 220 + 10, _ Width:=450, Height:=210) With myChart.Chart .ChartType = xlLine 折线图 .SetSourceData Source:=Cells(1, i).Resize(UBound(Arr), 1), _ PlotBy:=xlColumns .HasLegend = True .HasTitle = False .Axes(xlValue).MajorUnit = 10 主要分尺寸 .Axes(xlValue).MinimumScale = Int(mn - 10) / 10) * 10 最小值 .Axes(xlValue).MaximumScale = Int(mx + 10) / 10) * 10 最大值 End WithNextEnd Sub10, 根据指定级别自动制作多图表 2015-4-23/thread-342019-1-1.htmlPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Address $O$1 Then Exit SubDim Arr, i&, m&, j&Dim d, k, t, tt, ks, js, aa, c1%, c2%, c3%Set d = CreateObject(Scripting.Dictionary)Arr = a1.CurrentRegionFor i = 2 To UBound(Arr) d(Arr(i, 2) = d(Arr(i, 2) & i & ,Nextk = d.keys: tt = d.itemsIf d.exists(Target.Value) Then t = d(Target.Value) m = Application.Match(Target.Value, k, 0) + 1 t = Left(t, Len(t) - 1) If InStr(t, ,) Then aa = Split(t, ,) ks = aa(0): js = aa(UBound(aa) For j = 2 To 6 ActiveSheet.ChartObjects(图表 & j).Activate Select Case j Case 2 c1 = 4: c2 = 5: c3 = 6 Cas