户籍资料格式转换 (2)

考试加油站

一把小刀闯天下 发表于 2018-4-29 20:10
'可能户主单元格中有不可见字符？或者有空格？给你做了去空格处理，然后按包含来判断户主，再测试一下。
...

感谢非常，但问题是这样的，第二户“张5”是户主，却排列在家庭成员下，“张4”是家庭成员却排列在户主名下。

一把小刀闯天下

考试加油站 发表于 2018-4-29 21:53
感谢非常，但问题是这样的，第二户“张5”是户主，却排列在家庭成员下，“张4”是家庭成员却排列在户主名 ...

修改了一下再试试
Option Explicit

Sub test()
  Dim i, j, k, kk, arr, n, t, dt, tt
  dt = Timer
  With Sheets("数据库原表")
    arr = .Range("a2:e" & .Cells(Rows.Count, "c").End(xlUp).Row + 1)
  End With
  ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 1) <> arr(j + 1, 1) Or Len(arr(j + 1, 3)) = 0 Then
        tt = Replace(arr(i, 2), Space(1), vbNullString)
        If j > i And InStr(tt, "户主") = 0 Then '户主位置判断，同户号单人不做判断
          For k = i To j
            tt = Replace(arr(k, 2), Space(1), vbNullString)
            If InStr(tt, "户主") Then '找到户主
              For kk = 1 To UBound(arr, 2) '户主移到同户号的第一行
                t = arr(i, kk): arr(i, kk) = arr(k, kk): arr(k, kk) = t
              Next
              Exit For '找到户主移位后直接退出，因为不可能有2个户主
            End If
          Next
        End If
        For k = i To j
          n = n + 1
          If k = i Then '处理户主一行
            brr(n, 1) = arr(k, 5): brr(n, 2) = arr(k, 3): brr(n, 3) = arr(k, 4)
            If j > i Then '同户号多人
              brr(n, 4) = arr(k + 1, 3): brr(n, 5) = arr(k + 1, 4)
              k = k + 1 '处理户主一行时处理了2个人的数据，跳过下一行
            Else '同户号单人
              Exit For '不作其他人处理，直接退出
            End If
          Else
            brr(n, 4) = arr(k, 3): brr(n, 5) = arr(k, 4) '户主外多人
          End If
        Next
        i = j: Exit For '当前同户号的所有人处理完毕继续下一户号
      End If
  Next j, i
  Debug.Print Timer - dt
  With Sheets("转换后生成的表").[a3]
    .Resize(Rows.Count - 2, UBound(arr, 2)).ClearContents
    .Resize(n, UBound(brr, 2)) = brr
  End With
  Debug.Print Timer - dt
End Sub

考试加油站

一把小刀闯天下 发表于 2018-4-30 06:50
修改了一下再试试
Option Explicit

谢谢，测试成功

考试加油站

一把小刀闯天下 发表于 2018-4-30 06:50
修改了一下再试试
Option Explicit

在F列在增加一个与户主关系上去，不知道如何修改代码，谢谢

1. Sub test5() '按户号判断一家人，户主不必在第一个，户号可以交叉
   
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.   Dim aa
    
37.   For Each aa In d.keys
    
38.     brr = d(aa)
    
39.     crr(m, 1) = brr(5, 1)
    
40.     crr(m, 2) = brr(3, 1)
    
41.     crr(m, 3) = brr(4, 1)
    
42. 
    
43.    
    
44.     If UBound(brr, 2) > 1 Then
    
45.       For j = 2 To UBound(brr, 2)
    
46.         crr(m, 4) = brr(3, j)
    
47.         crr(m, 5) = brr(4, j)
    
48. 
    
49.    
    
50.         
    
51.         
    
52.         m = m + 1
    
53.       Next
    
54.     Else
    
55.       m = m + 1
    
56.     End If
    
57.   Next
    
58.   With Worksheets("转换后生成的表")
    
59.     .UsedRange.Offset(2, 0).ClearContents
    
60.     .Range("a3").Resize(m, UBound(crr, 2)) = crr
    
61.    ' .Range("a1:e" & m + 1).Borders.LineStyle = xlContinuous
    
62.   End With
    
63.   Application.ScreenUpdating = True
    
64.   MsgBox "数据整理完毕！共用时" & Timer - tt & "秒"
    
65. End Sub

复制代码