户口信息调整求助，附件如下

考试加油站

chxw68 发表于 2018-4-29 21:57
A列不是组别吗？

应当以这个作为原数据表

chxw68

考试加油站 发表于 2018-4-30 09:19
应当以这个作为原数据表

我看别人已经写好了，我就不重复写了。

chxw68

考试加油站 发表于 2018-4-30 09:19
应当以这个作为原数据表

张4和张5是一户家人，但两人的街路巷一个是二组2，一个是一组2！

考试加油站

chxw68 发表于 2018-4-30 09:34
张4和张5是一户家人，但两人的街路巷一个是二组2，一个是一组2！

这应当不影响的吧，我是想增加难度，如果将户号也打乱，不知道能不能做到

chxw68

考试加油站 发表于 2018-4-30 10:01
这应当不影响的吧，我是想增加难度，如果将户号也打乱，不知道能不能做到

如果用字典来做的话，与顺序没有关系。

chxw68

1. Sub test()
   
2.   Dim r&, i&
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   tt = Timer
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   With Worksheets("数据库原表")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a2:e" & r)
    
12.   End With
    
13.   For i = 1 To UBound(arr)
    
14.     If Not d.exists(arr(i, 1)) Then
    
15.       m = 1
    
16.       ReDim brr(1 To 5, 1 To m)
    
17.     Else
    
18.       brr = d(arr(i, 1))
    
19.       m = UBound(brr, 2) + 1
    
20.       ReDim Preserve brr(1 To 5, 1 To m)
    
21.     End If
    
22.     If arr(i, 2) = "户主" Then
    
23.       For j = 1 To 5
    
24.         brr(j, m) = brr(j, 1)
    
25.         brr(j, 1) = arr(i, j)
    
26.       Next
    
27.     Else
    
28.       For j = 1 To 5
    
29.         brr(j, m) = arr(i, j)
    
30.       Next
    
31.     End If
    
32.     d(arr(i, 1)) = brr
    
33.   Next
    
34.   ReDim crr(1 To UBound(arr), 1 To 5)
    
35.   m = 1
    
36.   For Each aa In d.keys
    
37.     brr = d(aa)
    
38.     crr(m, 1) = brr(5, 1)
    
39.     crr(m, 2) = brr(3, 1)
    
40.     crr(m, 3) = brr(4, 1)
    
41.     If UBound(brr, 2) > 1 Then
    
42.       For j = 2 To UBound(brr, 2)
    
43.         crr(m, 4) = brr(3, j)
    
44.         crr(m, 5) = brr(4, j)
    
45.         m = m + 1
    
46.       Next
    
47.     Else
    
48.       m = m + 1
    
49.     End If
    
50.   Next
    
51.   With Worksheets("转换后生成的表")
    
52.     .UsedRange.Offset(2, 0).ClearContents
    
53.     .Range("a3").Resize(m, UBound(crr, 2)) = crr
    
54.     .Range("a1:e" & m + 1).Borders.LineStyle = xlContinuous
    
55.   End With
    
56.   Application.ScreenUpdating = True
    
57.   MsgBox "数据整理完毕！共用时" & Timer - tt & "秒"
    
58. End Sub
    

复制代码

chxw68

练习练习。

考试加油站

chxw68 发表于 2018-4-30 10:55
练习练习。

谢谢了，不知道我电脑上怎么不能运行
删除了共黄色代码可以运行了。谢谢

chxw68

考试加油站 发表于 2018-4-30 12:45
谢谢了，不知道我电脑上怎么不能运行
删除了共黄色代码可以运行了。谢谢

把出错这一句注释掉试试。

考试加油站

chxw68 发表于 2018-4-30 20:33
把出错这一句注释掉试试。

谢谢，51快乐，注释掉后运行正常