根据名称，依次提取代码，并自动生成序列号

qianzhi

要求达到的效果是： 数据.rar (8.61 KB, 下载次数: 0) 1）输入图片3中名称后，编码按引用源中的数据进行填写，如线位移传感器，则先写一级代码，再写二级代码（见图片1），后二位是依据“已生成数据”工作表的相同名称的序号延续（见图片2），如已出现两次线位移传感器，则再在数据中出现，则后面两位变为03（见图片3） 2）如果完成数据填写后增加一个按钮，则将数据自动移动到“已生成数据”工作表中，而“数据”工作表内的数据清空，“已生成数据”工作表不得删除里面的信息 图1 图2 图3

Snap2.jpg (7.48 KB, 下载次数: 0)

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, crr, cr, d, d2, i&, s%, n&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. arr = Sheet1.Range("a1").CurrentRegion
   
7. brr = Sheet2.Range("a1").CurrentRegion
   
8. crr = Sheet3.Range("a1").CurrentRegion
   
9. ReDim cr(1 To UBound(crr) - 1, 1 To 2)
   
10. For i = 2 To UBound(arr)
    
11.     If arr(i, 2) = "" Then arr(i, 2) = arr(i - 2, 2)
    
12.     d(arr(i, 3)) = arr(i, 2) & arr(i, 4)
    
13. Next
    
14. For i = 2 To UBound(brr)
    
15.     d2(brr(i, 1)) = d2(brr(i, 1)) + 1
    
16. Next
    
17. For i = 2 To UBound(crr)
    
18.     If Not d2.exists(crr(i, 1)) Then s = 1 Else s = d2(crr(i, 1)) + 1
    
19.     cr(i - 1, 1) = crr(i, 1)
    
20.     cr(i - 1, 2) = d(crr(i, 1)) & Format(s, "00")
    
21. Next
    
22. n = Sheet2.Range("a65536").End(xlUp).Row + 1
    
23. Sheet2.Cells(n, 1).Resize(UBound(cr), 2) = cr
    
24. Sheet3.Range("a1").CurrentRegion.Offset(1, 0).ClearContents
    
25. End Sub

复制代码

grf1973

应该以一级名称+二级名称为key。

qianzhi

楼上的程序有些问题，如果是多个的会出现隔行正常，另一行则不正常，出现一级代码数值。见图片，


另能否在“数据”工作表也显示编码。
非常感谢。