ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1906|回复: 8

[已解决] 如何用VBA制作切割比例示图

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-9-1 00:23 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 aman1516 于 2018-9-3 00:04 编辑

如题,如何根据下料模式中的数据,用VBA生成对应比例的切割示图:
图片20180901000651.png
详见附件:
下料比例图.rar (30.67 KB, 下载次数: 25)

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-1 00:25 | 显示全部楼层
借用了"三坛老窖 "的图表作示例,在此表示致敬和感谢!

TA的精华主题

TA的得分主题

发表于 2018-9-1 01:16 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-9-1 09:28 | 显示全部楼层
真正的图表,供参考

下料比例图.zip

41.73 KB, 下载次数: 67

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-1 12:48 | 显示全部楼层
vbee 发表于 2018-9-1 09:28
真正的图表,供参考

非常强大!的确是真正的图表,但因为大数据时,动态数据生成的列数可能会几百列,能否不用辅助列?(当然可将辅助列数据放到尽可能大的列数后面)

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-1 12:58 | 显示全部楼层
这是 三坛老窖 大师的代码,只不过因为数据源来自于封装的模块内(过程调用),不知道如何改为本工作表数据调用,无从对接修改相关参数,代码太高深看不懂,可供参考,期望老师能就类似本表的数据格式实现一个通用模块:
  1. ' ===============================================================================
  2. ' 模块名称:  输出
  3. '
  4. Option Explicit

  5. ' ********************************************************************************
  6. ' 模块常数声明
  7. ' ********************************************************************************
  8. Private Const msMODULE As String = "OutputOptScheme"

  9. '   3   WorkOrder                   输出工单
  10. '   5   TestShape                   测试Shape存在与否
  11. '   6   CreateShape                 创建Shape
  12. ' ================================================================================
  13. ' 功能:输出最优方案的加工单
  14. '
  15. ' 描述:从myODC中提取最优方案数据,据此生成带图形的加工单
  16. '
  17. ' 参数:Sh -- 工作表对象
  18. '       myODC -- 一维下料对象
  19. '
  20. ' 返回:加工单(到方案文件中)
  21. '
  22. ' 备注:本过程由输出方案过程(OutpuScheme)调用
  23. ' ================================================================================
  24. Private Sub WorkOrder(Sh As Worksheet, myODC As Object)
  25.     Dim rng As Range
  26.     Dim shpPart As Shape
  27.     Dim i As Long, j As Long, k As Long, s As String, CutLoss As Long, ModeCount As Long
  28.     Dim PartTotalLenght As Long     '零件总长度
  29.     Dim rule As Double
  30.     Dim shpLeft As Double, shpTop As Double
  31.     Dim MaxLenght As Double
  32.     Dim ShapeLenght As Double
  33.     Dim ShapeHeight As Double
  34.     Dim RangeHeight As Double
  35.     Dim arr, arrM, arrP, temp1, temp2
  36.    
  37.     '从myODC中提取数据
  38.     With myODC
  39.         arr = .WorkOrderData: arrP = .PartData: arrM = .MaterialData: CutLoss = .CutWidth: ModeCount = .ModeCount
  40.     End With
  41.       
  42.     '获取最长的棒料长度(用于计算图形比例)
  43.     For i = LBound(arrM) To UBound(arrM)
  44.         If arrM(i, 1) > MaxLenght And arrM(i, 4) Then MaxLenght = arrM(i, 1)
  45.     Next i
  46.    
  47.     '输出数据及图形到工作表
  48.     With Sh
  49.         
  50.         '输出数据
  51.         .Range("CutWidth") = CutLoss
  52.         .Range("Date") = Date
  53.         
  54.         With .Range("ModeNo")
  55.             If ModeCount > 1 Then .Offset(1).Resize(ModeCount - 1).EntireRow.Insert
  56.             .Resize(ModeCount, 7) = arr
  57.             .Offset(ModeCount, 1).Resize(1, 6).FormulaR1C1 = _
  58.                 "=SUMPRODUCT(R[-" & ModeCount & "]C:R[-1]C,R[-" & ModeCount & "]C" & .Column + 2 & ":R[-1]C" & .Column + 2 & ")"
  59.             .Offset(ModeCount, 2).FormulaR1C1 = "=SUM(R[-" & ModeCount & "]C:R[-1]C)"
  60.         End With
  61.         
  62.         '检测Shape是否存在,若不存在则将被创建
  63.         TestShape .Range("ModeNo").Offset(, 3)
  64.         
  65.         ShapeLenght = .Shapes("M").Width
  66.         ShapeHeight = .Shapes("M").Height
  67.         RangeHeight = .Range("ModeNo").Height
  68.         
  69.         '长度变换比例
  70.         rule = ShapeLenght / MaxLenght
  71.         
  72.         '在工作表相应单元格中输出下料模式示图和字符串
  73.         For i = 1 To ModeCount
  74.             shpLeft = .Range("ModeNo").Offset(, 3).Left
  75.             shpTop = .Range("ModeNo").Offset(i - 1).Top + RangeHeight * 3 / 4 - ShapeHeight / 2
  76.             temp1 = Split(arr(i, 4), "+")
  77.             For j = 0 To UBound(temp1)
  78.                 temp2 = Split(temp1(j), "*")
  79.                 PartTotalLenght = PartTotalLenght + temp2(0) * temp2(1) * arr(i, 3)
  80.                 For k = 1 To temp2(1)
  81.                     Set shpPart = .Shapes("M").Duplicate
  82.                     With shpPart
  83.                         .Name = "P" & temp2(0)
  84.                         .Left = shpLeft
  85.                         .Top = shpTop
  86.                         .Width = temp2(0) * rule
  87.                     End With
  88.                     shpLeft = shpLeft + (temp2(0) + CutLoss) * rule
  89.                 Next k
  90.             Next j
  91.             '输出料头示图
  92.             If arr(i, 5) > 0 Then
  93.                 Set shpPart = .Shapes("T").Duplicate
  94.                 With shpPart
  95.                     .Name = "T" & arr(i, 5)
  96.                     .Left = shpLeft: shpPart.Top = shpTop
  97.                     .Width = arr(i, 5) * rule
  98.                 End With
  99.             End If
  100.         Next i
  101.         
  102.         '删除多余的形状
  103.         .Shapes.Range("M").Delete
  104.         .Shapes.Range("T").Delete
  105.         .Range("ModeNo").Offset(ModeCount, 3) = PartTotalLenght

  106.     End With
  107.    
  108. End Sub

  109. ' ================================================================================
  110. ' 功能:检测母形状是否存在,若不存在则创建母形状
  111. '
  112. ' 描述:采用形状复制方法(Shape.Duplicate)检测母形状是否存在,如果不存在,则调用
  113. '       创建形状子程序(CreateShape)创建母形状,否则删除复制品
  114. '
  115. ' 参数:rng -- 单元格对象,用于计算形状位置和尺寸
  116. '
  117. ' 返回:none
  118. '
  119. ' 备注:本过程由生成加工单过程(WorkOrder)调用
  120. ' ================================================================================
  121. Private Sub TestShape(rng As Range)
  122.     Dim shp As Shape

  123.     On Error Resume Next
  124.    
  125.     Set shp = ActiveSheet.Shapes("M").Duplicate
  126.     If Err.Number Then
  127.         With rng
  128.             CreateShape "M", "", .Left, .Top, .Width - 5, .Height * 3 / 10, vbYellow, vbRed
  129.         End With
  130.     Else
  131.         shp.Delete
  132.     End If
  133.    
  134.     Err.Clear
  135.    
  136.     Set shp = ActiveSheet.Shapes("T").Duplicate
  137.     If Err.Number Then
  138.         Set shp = ActiveSheet.Shapes("M").Duplicate
  139.         shp.Name = "T"
  140.         shp.Fill.ForeColor.RGB = vbBlue
  141.     Else
  142.        shp.Delete
  143.     End If
  144.    
  145. End Sub


  146. ' ================================================================================
  147. ' 功能:创建形状(矩形)
  148. '
  149. ' 描述:按输入参数创建形状(Shape)
  150. '
  151. ' 参数:1、shpName -- 形状名
  152. '       2、shpText -- 形状文本
  153. '       3、intLeft -- 左边位置
  154. '       4、intTop --  顶部位置
  155. '       5、intWidth -- 宽度
  156. '       6、intHeight --高度
  157. '       7、FillColor -- 形状填充色
  158. '       8、LineColor -- 形状外框线颜色
  159. '
  160. ' 返回:Shape
  161. '
  162. ' 备注:本过程由母形状检测过程(TestShape)调用
  163. ' ================================================================================
  164. Private Function CreateShape(ByVal shpName As String, _
  165.                     ByVal shpText As String, _
  166.                     ByVal intLeft As Double, _
  167.                     ByVal intTop As Double, _
  168.                     ByVal intWidth As Double, _
  169.                     ByVal intHeight As Double, _
  170.                     Optional ByVal FillColor As Long, _
  171.                     Optional ByVal LineColor As Long) As Shape
  172.    
  173.     Dim shp As Shape
  174.    
  175.     Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, intLeft, intTop, intWidth, intHeight)
  176.    
  177.     With shp
  178.         .Name = shpName
  179.         .Fill.ForeColor.RGB = FillColor
  180.         .Line.Weight = 1
  181.         .Line.ForeColor.RGB = LineColor
  182.         .TextFrame.Characters.Font.ColorIndex = 1
  183.         .TextFrame2.TextRange.Characters.Text = shpText
  184.     End With
  185.    
  186.     Set CreateShape = shp
  187. End Function
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-1 13:02 | 显示全部楼层
另外一点,图表尺寸能否中自动对应工作表行高,若调整行高后,重新生成的图表就对应不到行数据的位置了

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-3 00:04 | 显示全部楼层
借鉴 三坛老窖  的代码,简化参数及模块化语句,直接循环工作表的数据行,

.Shapes.AddShape(msoShapeRectangle, spleft, sptop, spwidth, spheight).Select

一个一个的画,自己搞掂!




TA的精华主题

TA的得分主题

发表于 2018-9-3 16:02 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 08:22 , Processed in 0.059937 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表