ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[已解决] 根据层级关系及前缀名,自动分派新文件名称

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-10-22 19:47 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 袁振涛 于 2017-10-22 22:33 编辑
  1. Public d As Object
  2. Sub aa()
  3.     Set d = CreateObject("Scripting.dictionary")
  4.     Dim Arr
  5.     ReDim Brr(1 To 1000)
  6.     Arr = [a1].CurrentRegion
  7.     For i = 3 To UBound(Arr)
  8.         If Arr(i, 4) <> "标准件" And Arr(i, 4) <> "外购件" Then
  9.             If Arr(i, 1) = 1 Then '一级
  10.                 AddNode Arr(i, 3), "1"
  11.                 Brr(i) = getFirstNodeNumber(Arr(i, 3))
  12.             End If
  13.             If Arr(i, 1) = 2 Then '二级
  14.                 AddNode Arr(i, 3), "2"
  15.                 Brr(i) = getSecondNodeNumber(Arr(i, 3))
  16.             End If
  17.             If Arr(i, 1) = 3 Then '三级
  18.                 AddNode Arr(i, 3), "3"
  19.                 Brr(i) = getThirdNodeNumber(Arr(i, 3))
  20.             End If
  21.             If Arr(i, 1) = 4 Then '四级
  22.                 AddNode Arr(i, 3), "4"
  23.                 Brr(i) = getFourNodeNumber(Arr(i, 3))
  24.             End If
  25.         Else
  26.             Brr(i) = ""
  27.         End If
  28.     Next
  29.     Sheets("测试用").[f1].Resize(UBound(Brr), 1) = (Application.Transpose(Brr))
  30. End Sub
  31. Sub AddNode(ByVal strType$, strLevel$)
  32.     d(strType & strLevel) = d(strType & strLevel) + 1
  33.     d(strLevel) = strType
  34.     For Each Key In d
  35.         If Right(Key, 1) > Val(strLevel) Then
  36.             d.Remove Key
  37.         End If
  38.     Next
  39. End Sub
  40. Function getFirstNodeNumber(ByVal strContent$) '一级装配体
  41.     If strContent = "sldprt" Then
  42.         getFirstNodeNumber = "YTKQFMS-0000-000-" & Format(d("sldprt1"), "000") & "-0"
  43.     Else
  44.         getFirstNodeNumber = "YTKQFMS-" & Format(d("sldasm1"), "0000") & "-000-000-0"
  45.     End If
  46. End Function
  47. Function getSecondNodeNumber(ByVal strContent$) '二级
  48.     If d("1") = "sldasm" And strContent = "sldprt" Then
  49.         getSecondNodeNumber = "YTKQFMS-" & Format(d("sldasm1"), "0000") & "-000-" & Format(d("sldprt2"), "000") & "-0"
  50.     End If
  51.     If d("1") = "sldasm" And strContent = "sldasm" Then
  52.         getSecondNodeNumber = "YTKQFMS-" & Format(d("sldasm1"), "0000") & "-" & Format(100 * d("sldasm2"), "000") & "-000-0"
  53.     End If
  54.     If d("1") = "sldprt" And strContent = "sldprt" Then
  55.         getSecondNodeNumber = "YTKQFMS-" & Format(d("sldprt2"), "0000") & "-000-" & Format(d("sldprt1"), "000") & "-0"
  56.     End If
  57.     If d("1") = "sldprt" And strContent = "sldasm" Then
  58.         getSecondNodeNumber = "YTKQFMS-0000-" & Format(d("sldasm2"), "000") & Format(100 * d("sldprt1"), "000") & "-0"
  59.     End If
  60. End Function
  61. Function getThirdNodeNumber(ByVal strContent$) '三级,拆分二级来得到
  62.     Dim strResult
  63.     strResult = Split(getSecondNodeNumber(d("2")), "-")
  64.     If strContent = "sldprt" Then
  65.         getThirdNodeNumber = strResult(0) & "-" & strResult(1) & "-" & strResult(2) & "-" & Format(Val(strResult(3)) + d("sldprt3"), "000") & "-" & strResult(4)
  66.     Else
  67.         getThirdNodeNumber = strResult(0) & "-" & strResult(1) & "-" & Format(Val(strResult(2)) + d("sldasm3"), "000") & "-" & strResult(3) & "-" & strResult(4)
  68.     End If
  69. End Function
  70. Function getFourNodeNumber(ByVal strContent$) '四级,拆分三级来得到
  71.     Dim strResult
  72.     strResult = Split(getThirdNodeNumber(d("3")), "-")
  73.     If strContent = "sldprt" Then
  74.         getFourNodeNumber = strResult(0) & "-" & strResult(1) & "-" & strResult(2) & "-" & Format(Val(strResult(3)) + d("sldprt4"), "000") & "-" & strResult(4)
  75.     End If
  76. End Function
复制代码

TA的精华主题

TA的得分主题

发表于 2017-10-22 19:49 | 显示全部楼层
附件仅供参考

自动指派名字.rar

89.18 KB, 下载次数: 13

TA的精华主题

TA的得分主题

发表于 2017-10-22 20:24 | 显示全部楼层
口风琴 发表于 2017-10-22 19:13
对的,希望老师能继续完善下,谢谢

楼主做了不少指示图,但是核心问题要报让别人明白楼主的意图
建议楼主,只考虑零件或者配体,考虑一个,看着两个是独立的,实现逻辑相当
用其中之一,结合附件中数据的每次层级表换,来说明变化的实现方式

TA的精华主题

TA的得分主题

发表于 2017-10-22 21:31 | 显示全部楼层
装配体和零件的层级相同的话,区分规则是什么?

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-10-22 21:38 | 显示全部楼层

感谢袁老师援助,代码分配的名字很准确,代码很长,辛苦老师了

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-10-22 22:01 | 显示全部楼层
jsgj2023 发表于 2017-10-22 21:31
装配体和零件的层级相同的话,区分规则是什么?

后缀名 sldasm   →→装配体

后缀名 sldprt   →→零件

老师详见第22楼规则

点击进入22楼

TA的精华主题

TA的得分主题

发表于 2017-10-22 22:41 | 显示全部楼层
代码又优化了下
另外,在添加各级节点的时候是完全可以考虑用加载到treeview里面去的,最后结果肯定漂亮

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-10-22 23:05 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
袁振涛 发表于 2017-10-22 22:41
代码又优化了下
另外,在添加各级节点的时候是完全可以考虑用加载到treeview里面去的,最后结果肯定漂亮

辛苦老师,袁老师对代码精益求精,是我辈学习的楷模,treeview控件我很少使用,对其研究只知皮毛,待慢慢积累。另外我在liulang版主的基础上又修改了一些,能否在如下代码基础上再进行修改实现功能,望老师指点

  1. Sub 按钮_Click()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     arr = [a1].CurrentRegion
  4.     Dim Brr(0 To 4)
  5.     '    Range("E2:E80").Clear
  6.     For j = 0 To 3
  7.         d(j) = 0
  8.     Next j
  9.     For j = 3 To UBound(arr)
  10.         If Cells(j, 4) = "外购件" Or Cells(j, 4) = "标准件" Then
  11.             arr(j, 5) = Cells(j, 2)
  12.         Else
  13.             For i = 1 To 4
  14.                 If InStr(arr(j, 1), i) > 0 Then
  15.                     If arr(j, 1) >= arr(j - 1, 1) Then
  16.                         nub = Brr(i)
  17.                     Else
  18.                         nub = 0
  19.                         Brr(Cells(j - 1, 1)) = nub
  20.                     End If
  21.                     If UCase(Cells(j, 3)) = "SLDASM" Then
  22.                         Debug.Print d(0), d(1), d(2), d(3)
  23.                         d(i - 1) = d(i - 1) + 1
  24.                         For k = i To 3
  25.                             d(k) = 0
  26.                         Next k
  27.                     Else
  28.                         nub = nub + 1
  29.                         Brr(i) = nub
  30.                         d(3) = nub
  31.                         For k = i - 1 To 2
  32.                             d(k) = 0
  33.                         Next k
  34.                     End If
  35.                     Debug.Print d(0), d(1), d(2), d(3)
  36.                     arr(j, 5) = "YTKQFMS-60" & Format(d(0), "00") & Format(d(1), "-0") & Format(d(2), "00") & "-" & Format(d(3), "000") & "-0"
  37.                     Exit For
  38.                 End If
  39.             Next i
  40.         End If
  41.     Next j
  42.     [a1].CurrentRegion = arr
  43. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2017-10-23 10:22 | 显示全部楼层
  1. Public d As Object
  2. Sub aa()
  3.     Set d = CreateObject("Scripting.dictionary")
  4.     Dim Arr
  5.     ReDim Brr(1 To 1000)
  6.     Arr = [a1].CurrentRegion
  7.     For i = 3 To UBound(Arr)
  8.         If Arr(i, 4) <> "标准件" And Arr(i, 4) <> "外购件" Then
  9.             Brr(i) = getNode(Arr(i, 3), Arr(i, 1))
  10.         Else
  11.             Brr(i) = Arr(i, 4)
  12.         End If
  13.     Next
  14.     Sheets("测试用").[g1].Resize(UBound(Brr), 1) = (Application.Transpose(Brr))
  15. End Sub
  16. Function getNode(ByVal strType$, ByVal strLevel$)
  17.     d(strType & strLevel) = d(strType & strLevel) + 1
  18.     d(strLevel) = strType
  19.     For Each Key In d
  20.         If Right(Key, 1) > Val(strLevel) Then
  21.             d(Key) = 0
  22.         End If
  23.     Next
  24.     strContent = "YTKQFMS-" & strContent & Format(IIf(d("1") = "sldasm", d("sldasm1"), 0) + IIf(d("1") = "sldprt", d("sldprt2"), 0), "0000") & "-"
  25.     strContent = strContent & Format(IIf(d("2") = "sldasm", IIf(d("1") = "sldasm", 100, 1) * d("sldasm2"), 0) + IIf(d("3") = "sldasm", d("sldasm3"), 0), "000") & "-"
  26.     strContent = strContent & Format(IIf(d("4") = "sldprt", d("sldprt4"), 0) + IIf(d("3") = "sldprt", d("sldprt3"), 0) + IIf(d("1") = "sldprt", d("sldprt1"), IIf(d("2") = "sldprt", d("sldprt2"), IIf(d("2") = "sldprt", d("sldprt2"), 0))), "000") & "-0"
  27.     getNode = strContent
  28. End Function
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-10-23 11:13 | 显示全部楼层

厉害了袁老师,老师的函数和代码应用我辈唯有惊叹,定当加强学习
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 21:03 , Processed in 0.062418 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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