[已解决]怎么批量生成农户编号，谢谢

qtwrey

1、黄线左边是新数据，需要生成农户编号。
2、需要实现的功能就是批量智能的识别每个人对应的村组，并且识别该组的最大编号，然后将新数据中的人按照对应的村组逐个编号，排列在原数据之后
3、农户编号共17位，前六位为666888
   7-9位是001，代表乡镇号
   10-12位是村序号，如东渠岸001 南大街005
   13-14位是组序号，01是一组，02是二组
   15-17位是农户序号，001起，最大999
4、举例左边的第一个人王园月，他属于东渠岸村一组，该村的最大编号排到了30，那么王圆月的编号应该为432111200100101031，下一个人就是432111200100101032，一次类推。
5、数据量很大，目前共有32万条
6、请各位高手帮帮忙，谢谢大家！

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-18 23:02

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("f1").CurrentRegion
   
5. brr = Range("a4").CurrentRegion
   
6. ReDim crr(1 To UBound(brr) - 1, 1 To 3)
   
7. For i = 3 To UBound(arr)
   
8.     If Len(arr(i, 1)) = 12 Then d(arr(i, 2)) = arr(i, 1)
   
9.     If Len(arr(i, 1)) = 14 Then d(arr(i, 2)) = Right(arr(i, 1), 2)
   
10.     If Len(arr(i, 1)) = 17 Then
    
11.         d(arr(i, 3)) = ""
    
12.         zf = Left(arr(i, 1), 14)
    
13.         zf2 = Val(Right(arr(i, 1), 3))
    
14.         If Not d.exists(zf) Then
    
15.             d(zf) = zf2
    
16.         Else
    
17.         If zf2 > d(zf) Then d(zf) = zf2
    
18.         End If
    
19.     End If
    
20. Next
    
21. For i = 2 To UBound(brr)
    
22.     If Not d.exists(brr(i, 3)) Then
    
23.         s = s + 1
    
24.         zf = d(brr(i, 1)) & d(brr(i, 2))
    
25.         d(zf) = d(zf) + 1
    
26.         crr(s, 1) = zf & Format(d(zf), "000")
    
27.         crr(s, 2) = brr(i, 4)
    
28.         crr(s, 3) = brr(i, 3)
    
29.     End If
    
30. Next
    
31. If s Then Range("f37").Resize(s, 3) = crr
    
32. End Sub

复制代码

跳转到最佳答案楼层

baksy

附件

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("f1").CurrentRegion
   
5. brr = Range("a4").CurrentRegion
   
6. ReDim crr(1 To UBound(brr) - 1, 1 To 3)
   
7. For i = 3 To UBound(arr)
   
8.     If Len(arr(i, 1)) = 12 Then d(arr(i, 2)) = arr(i, 1)
   
9.     If Len(arr(i, 1)) = 14 Then d(arr(i, 2)) = Right(arr(i, 1), 2)
   
10.     If Len(arr(i, 1)) = 17 Then
    
11.         d(arr(i, 3)) = ""
    
12.         zf = Left(arr(i, 1), 14)
    
13.         zf2 = Val(Right(arr(i, 1), 3))
    
14.         If Not d.exists(zf) Then
    
15.             d(zf) = zf2
    
16.         Else
    
17.         If zf2 > d(zf) Then d(zf) = zf2
    
18.         End If
    
19.     End If
    
20. Next
    
21. For i = 2 To UBound(brr)
    
22.     If Not d.exists(brr(i, 3)) Then
    
23.         s = s + 1
    
24.         zf = d(brr(i, 1)) & d(brr(i, 2))
    
25.         d(zf) = d(zf) + 1
    
26.         crr(s, 1) = zf & Format(d(zf), "000")
    
27.         crr(s, 2) = brr(i, 4)
    
28.         crr(s, 3) = brr(i, 3)
    
29.     End If
    
30. Next
    
31. If s Then Range("f37").Resize(s, 3) = crr
    
32. End Sub

复制代码

qtwrey

谢谢baksy和dsmch 。哈哈 ，竟然函数和vba都可以实现，太棒了！
不过我还不是很懂，我先用吧，明天试着多加些数据进去看看.
今天下午开会还在头疼，没想到到了这里这么快就得到的答案，谢谢本论坛，非常感谢上面两位！