Excel VBA_批量自动制图表实例集锦

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) - 1nm = yy = Left(nm, Len(nm) - 3)nm1 = "图表6"nm2 = "图表4"dz = "A2:B" & js & ",D2:E" & jsActiveSheet.ChartObjects(nm1).ActivateWith ActiveChart.SetSourceData Source:=Sheets(nm).Range(dz), PlotBy:=xlColumns.SeriesCollection(1).Selectdz1 = "R3C2:R" & js & "C2".SeriesCollection(1).Values = "='" & nm & "'!" & dz1dz2 = "R3C4:R" & js & "C4".SeriesCollection(2).Values = "='" & nm & "'!" & dz2dz3 = "R3C5:R" & js & "C5".SeriesCollection(3).Values = "='" & nm & "'!" & dz3.ChartTitle.SelectSelection.Characters.Text = yy & "月份合格率"End WithActiveSheet.ChartObjects(nm2).ActivateWith ActiveChart.ChartArea.Selectdz = "H2:T2,H" & js + 1 & ":T" & js + 1.SetSourceData Source:=Sheets(nm).Range(dz), PlotBy:= _xlRowsdz2 = "R" & js + 1 & "C8:R" & js + 1 & "C20".SeriesCollection(1).Values = "='" & nm & "'!" & dz2.ChartTitle.SelectSelection.Characters.Text = yy & "月份不良趋势统计"End WithRange("A" & ks).SelectApplication.ScreenUpdating = True MsgBox "OK"End Sub2, 批量插入图表‘2010-9-27‘批量绘图表.xlsSub ChartsAdd()Dim myChart As ChartObjectDim i As IntegerDim R As IntegerDim m As IntegerR = Sheet1.Range("A65536").End(xlUp).Row - 1m = Abs(Int(-(R / 4)))Sheet2.ChartObjects.DeleteFor i = 1 To RSet 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:=xlRowsWith .SeriesCollection(1).XValues = Sheet1.Range("B1:M1").Name = Sheet1.Range("A2").Offset(i - 1).ApplyDataLabels AutoText:=True, ShowValue:=True.DataLabels.Font.Size = 10End With.HasLegend = FalseWith .ChartTitle.Left = 5.Top = 1.Font.Size = 14 = "华文行楷"End WithWith .PlotArea.Interior.ColorIndex = 2.PatternColorIndex = 1.Pattern = xlSolidEnd With.Axes(xlCategory).TickLabels.Font.Size = 10.Axes(xlValue).TickLabels.Font.Size = 10End WithNextSheet2.SelectSet 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 2j = Sheet1.Range("A65536").Offset(0, i - 1).End(xlUp).RowSet myX = Sheet1.Cells(4, i).Resize(j - 3, 1)Set myY = myX.Offset(0, 1)With .SeriesCollection.NewSeries.Values = myY.XV alues = myX.Name = Sheet1.Cells(1, i).Value ‘序列名.MarkerStyle = -4142 ‘没有标志显示End WithNext iEnd With[a1].SelectApplication.ScreenUpdating = TrueEnd Sub4, 图表对象您可以结合使用Add 方法和ChartWizard 方法，添加包含工作表数据的新图表。

本示例将基于名为Sheet1 的工作表上单元格A1:A20 中的数据添加一个新的折线图。

With Charts.Add.ChartWizard source:=Worksheets("Sheet1").Range("A1:A20"), _Gallery:=xlLine, Title:="February Data"End 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:Lee1892‘2013-12-03Private Sub KeepSquare()Dim dXDiff#, dYDiff#, dDiff#Dim dXMin#, dXMax#, dYMin#, dYMax#With ChartObjects(1).ChartWith .Axes(xlCategory).MaximumScaleIsAuto = True.MinimumScaleIsAuto = TruedXMax = .MaximumScale: dXMin = .MinimumScaledXDiff = dXMax - dXMinEnd WithWith .Axes(xlValue).MaximumScaleIsAuto = True.MinimumScaleIsAuto = TruedYMax = .MaximumScale: dYMin = .MinimumScaledYDiff = dYMax - dYMinEnd WithdDiff = dXDiffIf dXDiff < dYDiff Then dDiff = dYDiffWith .Axes(xlCategory).MaximumScale = dXMax + (dDiff - dXDiff) / 2.MinimumScale = dXMin - (dDiff - dXDiff) / 2End WithWith .Axes(xlValue).MaximumScale = dYMax + (dDiff - dYDiff) / 2.MinimumScale = dYMin - (dDiff - dYDiff) / 2End WithEnd 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 SheetsIf <> Then Sht.DeleteNext ShtArr = [a1].CurrentRegionFor i = 3 To UBound(Arr)If Arr(i, 1) <> "" Thenr = r + 1ReDim Preserve Arr1(1 To r)Arr1(r) = iEnd IfNextFor i = 1 To rIf i <> r Thenjs = Arr1(i + 1) - 1Elsejs = UBound(Arr)End Ifks = Arr1(i)Sht1.Copy after:=Sheets(Sheets.Count) = Arr(ks, 1)[a3:e500].ClearContentsSht1.Cells(ks, 1).Resize(js - ks + 1, 5).Copy [a3]nm = Arr(ks, 1)ActiveSheet.ChartObjects(1).ActivateWith ActiveChart.SetSourceData Source:=Sheets(nm).Range(dz), PlotBy:=xlColumns.FullSeriesCollection(1).SelectSelection.Formula = "=SERIES(" & nm & "!R2C4," & nm & "!R3C1:R" & js - ks + 3 & "C2," & nm & "!R3C4:R" & js - ks + 3 & "C4,1)".FullSeriesCollection(2).SelectSelection.Formula = "=SERIES(" & nm & "!R2C5," & nm & "!R3C1:R" & js - ks + 3 & "C2," & nm & "!R3C5:R" & js - ks + 3 & "C5,2)".FullSeriesCollection(3).Delete.FullSeriesCollection(3).DeleteEnd WithNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub7, 自动制作多图表‘/thread-919757-1-1.html‘2012-9-13Sub ChartsAdd()Dim myChart As ChartObjectDim i As IntegerDim R As IntegerR = Int(Sheet1.Range("A65536").End(xlUp).Row - 1) / 20ActiveSheet.ChartObjects.DeleteFor i = 1 To RSet 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 WithNextSet myChart = NothingEnd Sub‘2014-5-4‘/thread-1118085-1-1.htmlSub ChartsAdd()Dim myChart As ChartObjectDim Myc%, i&On Error Resume NextMyc = [iv3].End(xlToLeft).Columnnm = ActiveSheet.ChartObjects.DeleteFor i = 1 To Myc Step 8Set 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 WithmyChart.ActivateWith 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).ValueWith .ChartTitle.Format.TextFrame2.TextRange.Font.Size = 14End WithEnd WithNextSet myChart = NothingEnd Sub8, 自动生成图表‘2014-8-5‘/thread-1142829-1-1.htmlSub lqxs()Dim Myr&, bt$Myr = Cells(Rows.Count, 1).End(xlUp).RowActiveSheet.ChartObjects.DeleteActiveSheet.ChartObjects.Add Left:=[g3].Left, _Top:=[g3].Top, _Width:=[g3].Resize(1, 7).Width, Height:=[g3].Resize(16, 1).HeightActiveSheet.ChartObjects(1).ActivateWith 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 = boBox2.Text.Axes(xlValue, xlPrimary).HasTitle = True.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = boBox1.Text.Axes(xlValue).MajorUnit = 1.ChartTitle.SelectWith Selection.Font.FontStyle = "加粗".Size = 18End With.PlotArea.SelectWith Selection.Border.Weight = xlThin.LineStyle = xlNoneEnd WithSelection.Interior.ColorIndex = xlNoneEnd WithRange("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).Leftmx = 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) Thent = d(Target.Value)m = Application.Match(Target.Value, k, 0) + 1t = Left(t, Len(t) - 1)If InStr(t, ",") Thenaa = Split(t, ",")ks = aa(0): js = aa(UBound(aa))For j = 2 To 6ActiveSheet.ChartObjects("图表" & j).ActivateSelect Case jCase 2c1 = 4: c2 = 5: c3 = 6Case 3c1 = 6: c2 = 7: c3 = 8Case 4c1 = 6: c2 = 7: c3 = 9Case 5c1 = 6: c2 = 7: c3 = 10Case 6c1 = 6: c2 = 7: c3 = 11End SelectWith ActiveChart.PlotArea.Select.ChartType = xlBubble.SeriesCollection(1).XValues = "=统计!R" & ks & "C" & c1 & ":R" & js & "C" & c1.SeriesCollection(1).Values = "=统计!R" & ks & "C" & c2 & ":R" & js & "C" & c2.SeriesCollection(1).BubbleSizes = "=统计!R" & ks & "C" & c3 & ":R" & js & "C" & c3.SeriesCollection(1).Name = "=统计!R" & ks & "C2"End WithNextEnd IfEnd If 'End Sub11, 自动制作多图表(散点图+趋势线)‘2015-4-30‘/thread-342407-1-1.htmlSub ChartsAdd_lqxs()Dim myChart As ChartObjectDim i&, R&R = Int(Sheet1.Range("A65536").End(xlUp).Row - 1) / 6ht = [a2:a16].Height: wt = [f1:l1].WidthActiveSheet.ChartObjects.DeleteFor i = 1 To RSet myChart = Sheet1.ChartObjects.Add _(Left:=[f1].Left, _Top:=(i - 1) * 210, _Width:=wt, Height:=ht)With myChart.Chart.ChartType = xlXYScatter.SetSourceData Source:=Cells(6 * i - 4, 1).Resize(5, 2).FullSeriesCollection(1).Trendlines.Add.FullSeriesCollection(1).Trendlines(1).SelectWith Selection.Type = xlPolynomial.Order = 3End WithSelection.DisplayEquation = TrueSelection.DisplayRSquared = TrueEnd WithNextSet myChart = NothingEnd Sub。