|
|
首先申明本人对帕拉图不了解，只是对楼主附件图表的一个克隆。
一键生成柏拉图.zip
(21.33 KB, 下载次数: 102)
sheet1代码：
Private Sub CommandButton1_Click()
Pareto
End Sub
模块代码：
Sub Pareto()
Dim Myshe As Worksheet, Myra1 As Range, Myra2 As Range, Myrar As Range '声明变量
Set Myshe = Application.ActiveSheet '设置对象
Set Myra1 = Myshe.Range("C11:G12") '设置对象
Set Myra2 = Myshe.Range("B14:G14") '设置对象
Myra1.Sort key1:=Myra1.Cells(2, 1), Order1:=xlDescending, header:=xlGuess, _
Orientation:=xlSortRows '设置按由高到低排序
Set Myrar = Union(Myra1, Myra2) '设置对象返回多块区域
'以下为调用函数-----------------------------------------------------------
MyChart MyChart_Name:="我的Pareto图表", MyChart_Source:=Myrar, MyChart_Plotby:=xlRows, _
MyChart_Title:=False, MyTypeName:="两轴线-柱图"
End Sub
Function MyChart(Optional ByVal MyChart_Name As String = "我的图表", Optional ByVal MyChart_Type As XlChartType = xlColumnClustered, _
Optional ByVal MyChart_Source As Range = Nothing, Optional ByVal MyChart_Plotby As XlRowCol = xlRows, _
Optional ByVal MyChart_Title As Boolean = True, Optional ByVal MyChart_TitleText As String = "标题", _
Optional ByVal MyChart_HasLegend As Boolean = False, _
Optional ByVal MyChart_Left As Integer = 420, Optional ByVal MyChart_Top As Integer = 250, _
Optional ByVal MyChart_Width As Integer = 300, Optional ByVal MyChart_Height As Integer = 200, _
Optional ByVal MyTypeName As String = "") As Boolean
Dim Mych As ChartObject '声明变量为嵌入式图表对象
On Error Resume Next '如出错,则从出错行下一行开始执行
Set Mych = ActiveSheet.ChartObjects(MyChart_Name) '设置对象
'MsgBox Err.Number
If Err.Number <> 0 Then '设置对象出错,没有对象
Set Mych = ActiveSheet.ChartObjects.Add(MyChart_Left, MyChart_Top, MyChart_Width, MyChart_Height) '添加嵌入图表,设置对象
Mych.Name = MyChart_Name '设置对象名称
End If
Err.Clear '清除Err对象
On Error GoTo Myerr '如出错,则执行Myerr语句
With Mych.Chart
.ChartType = MyChart_Type '图表类型为xlLineMarkers_数据点折线图
.SetSourceData Source:=MyChart_Source, PlotBy:=MyChart_Plotby '为指定图表设置源数据区域
If MyTypeName <> "" Then .ApplyCustomType ChartType:=xlBuiltIn, TypeName:=MyTypeName '设置图表为自定义图表
.HasLegend = MyChart_HasLegend '为False ,图表没有图例
.HasTitle = MyChart_Title '图表标题，可见则为 True
If MyChart_Title Then .ChartTitle.Characters.Text = MyChart_TitleText '图表标题文本
'.ChartTitle.Characters.Font.Size = 12 '设置标题的字号
.HasAxis(xlCategory, xlSecondary) = True '设置图表中的次坐标轴(X轴)_显示
With .Axes(xlValue) '设置图表单个坐标轴_主坐标轴(Y轴)
.MaximumScale = 100 '设置图表_主坐标轴(Y轴)刻度最大值
.MajorUnit = 20 '设置图表_主坐标轴(Y轴)主要刻度单位
End With
With .Axes(xlValue, xlSecondary) '设置图表单个坐标轴_次坐标轴(Y轴)
.MaximumScale = 1 '设置图表_次坐标轴(Y轴)刻度最大值
.MajorUnit = 0.2 '设置图表_次坐标轴(Y轴)主要刻度单位
.TickLabels.NumberFormat = "0%" '设置图表_次坐标轴(Y轴)数字格式为%
End With
With .Axes(xlCategory, xlSecondary) '设置图表中的次坐标轴(X轴)
.TickLabelPosition = xlNone '设置图表中的次坐标轴(X轴)_无标签
.MajorTickMark = xlInside '设置图表中的次坐标轴(X轴)_主刻度线在内侧
.AxisBetweenCategories = False '设置图表中的次坐标轴(X轴)_数值在刻度线上
End With
With .ChartGroups(1) '返回图表中单个图表组
.GapWidth = 0 '柱形簇之间的距离
.VaryByCategories = True '对每个数据标志指定不同的颜色或模式
End With
With .SeriesCollection(2)
.ApplyDataLabels ShowValue:=True '系列2_显示数据标签
.MarkerBackgroundColorIndex = 46 '系列2_数据标记背景色为红色
.MarkerSize = 7 '系列2_数据标记大小为7磅
.Points(.Points.Count).DataLabel.Delete '系列2_最后1个数据标签不显示
.Points(1).DataLabel.Delete '系列2_第1个数据标签不显示
End With
End With
Mych.Activate '对象激活
MyChart = True '本函数返回True
Exit Function '退出函数
Myerr:
MyChart = False '本函数返回False
End Function
郑重声明：本人从来看贴不回贴，文化程度极低，基本文盲，上网主要是学识字和打字，可能因为微机中毒来到本论坛，为了不引起不必要的误会和纠纷，特在此郑重声明，声明如下:
1. 本人是文盲，以上内容文字均不认识，也看不懂是什么意思。
2. 此事与本人一点关系都没有，本人过去、现在以及将来都不认识楼主，且自古以来与楼主无任何利益关系。本人过去、现在以及将来都没有且不准备与楼主有任何生意或业务或人事或复仇关系。楼主表述之事与本人无关，只是本着“看贴（虽然看不懂）回贴，利人利己的中华民族优秀传统美德”，顺便赚几个积分。
3. 本人在此留言均为网络上复制，用于检验本人电脑键盘录入、屏幕显示的机械、光电性能。并不代表本人局部或全部同意、支持或者反对楼主观点。
4. 本回贴不暗示、鼓励、支持或映射读者作出生活方式、工作态度、婚姻交友、子女教育的积极或消极判断。
5. 如本人留言违反国家有关法律，请网络管理员及时删除本人跟贴。
6. 因删贴不及时所产生的任何法律（包括括宪法，民法，刑法，书法，公检法，基本法，劳动法，婚姻法，输入法，没办法，国际法，今日说法，吸星大法，与台湾关系法及文中涉及或可能涉及以及未涉及之法，各地治安管理条例）纠纷或责任本人概不负责。
7. 本人谢绝任何跨村、跨乡、跨县、跨市、跨省、跨国、跨地球、跨银河系抓捕行为，如有需要请直接联系楼主、原作者以及网络管理员或法人代表。
8. 以上内容全部来自互联网，完全复制粘贴。看帖者请于24小时内自觉、主动、被动、完全忘记。跟帖行为并不意味本人同意、支持、反对，或了解、知晓文中观点，如有任何疑问请直接联系原作者本人。
9. 此声明最终解释权归本人所有。
|
|
楼主: qamiao
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-5-3 14:08
楼主
