[已解决]求编一个VBA 要求见附件。

tzjx200521

求编一个VBA 要求见附件。

最佳答案

月排行榜 / 总排行榜

wp8680

2014-6-28 20:53

1. Sub 编号()
   
2.     Dim d1, k, arr, brr, a
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     With Sheets("已有编号数据")
   
5.         arr = .Range("a2:b" & .Range("a" & .Cells.Rows.Count).End(xlUp).Row)
   
6.         For k = 1 To UBound(arr, 1)
   
7.             d1(arr(k, 2)) = d1(arr(k, 2)) & "|" & arr(k, 1) & "|"
   
8.         Next k
   
9.     End With
   
10.     With Sheets("sheet1")
    
11.         brr = .Range("a2:b" & .Range("b" & .Cells.Rows.Count).End(xlUp).Row)
    
12.         For k = 1 To UBound(brr, 1)
    
13.             a = 0
    
14.             Do
    
15.                 a = a + 1
    
16.                 If InStr(d1.Item(brr(k, 2)), "|" & a & "|") = 0 Then
    
17.                     brr(k, 1) = a
    
18.                     d1(brr(k, 2)) = d1(brr(k, 2)) & "|" & a & "|"
    
19.                     Exit Do
    
20.                 End If
    
21.             Loop
    
22.         Next k
    
23.         .Range("a2:b" & .Range("b" & .Cells.Rows.Count).End(xlUp).Row) = brr
    
24.     End With
    
25. End Sub

复制代码

跳转到最佳答案楼层

wp8680

1. Sub 编号()
   
2.     Dim d1, k, arr, brr, a
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     With Sheets("已有编号数据")
   
5.         arr = .Range("a2:b" & .Range("a" & .Cells.Rows.Count).End(xlUp).Row)
   
6.         For k = 1 To UBound(arr, 1)
   
7.             d1(arr(k, 2)) = d1(arr(k, 2)) & "|" & arr(k, 1) & "|"
   
8.         Next k
   
9.     End With
   
10.     With Sheets("sheet1")
    
11.         brr = .Range("a2:b" & .Range("b" & .Cells.Rows.Count).End(xlUp).Row)
    
12.         For k = 1 To UBound(brr, 1)
    
13.             a = 0
    
14.             Do
    
15.                 a = a + 1
    
16.                 If InStr(d1.Item(brr(k, 2)), "|" & a & "|") = 0 Then
    
17.                     brr(k, 1) = a
    
18.                     d1(brr(k, 2)) = d1(brr(k, 2)) & "|" & a & "|"
    
19.                     Exit Do
    
20.                 End If
    
21.             Loop
    
22.         Next k
    
23.         .Range("a2:b" & .Range("b" & .Cells.Rows.Count).End(xlUp).Row) = brr
    
24.     End With
    
25. End Sub

复制代码

tzjx200521

1. Sub bxdlbh()    '编写电路编号
   
2.     On Error Resume Next
   
3.     Dim x As String, y As String, z%, x1 As String, y1 As String, z1%, bh, d, bh1
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     With Sheets("已有编号数据")
   
7.         For z = 2 To .Cells(.Cells.Rows.Count, "b").End(xlUp).Row
   
8.             x = .Cells(z, "b") & "-" & .Cells(z, "a")
   
9.          
   
10.                 d(x) = x
    
11.         Next
    
12.     End With
    
13.     With Sheets("sheet1")
    
14. 
    
15.         .Columns("a:a").Select
    
16.         Selection.NumberFormatLocal = "@"
    
17.         For z1 = 2 To .Cells(Cells.Rows.Count, "b").End(xlUp).Row
    
18.            .Cells(z1, "a") = 1
    
19.             x1 = .Cells(z1, "b") & "-" & .Cells(z1, "a")
    
20.            Do While d(x1)
    
21.           .Cells(z1, "a") = .Cells(z1, "a") + 1
    
22.               x1 = .Cells(z1, "b") & "-" & .Cells(z1, "a")
    
23.                  
    
24.             Loop
    
25.             d(x1) = x1
    
26.         Next
    
27.         
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.    
    
31. End Sub
    

复制代码