户籍资料格式转换 (2)

一把小刀闯天下

考试加油站 发表于 2018-4-28 15:21
谢谢，经测试没有成功。全部数据都跑到家庭成员那儿了

数据表格式又修改了？按17楼附件测试。
户籍资料格式转换D.zip (1.5 MB, 下载次数: 70)

2018-4-28 15:25 上传

点击文件名下载附件

考试加油站

一把小刀闯天下 发表于 2018-4-28 15:26
数据表格式又修改了？按17楼附件测试。

这是什么版本，怎么打不开

一把小刀闯天下

考试加油站 发表于 2018-4-28 18:56
这是什么版本，怎么打不开

户籍资料格式转换D.rar (880.28 KB, 下载次数: 10)

2018-4-28 19:02 上传

点击文件名下载附件

另存为xls文档了，可能你用的低版本的office。

考试加油站

一把小刀闯天下 发表于 2018-4-28 19:04
另存为xls文档了，可能你用的低版本的office。

感谢帮忙，但对于我刚才发的附件是不成功的，有空请测试
户籍资料格式转换 (2)DD.rar (742.97 KB, 下载次数: 4)

2018-4-28 19:17 上传

点击文件名下载附件

一把小刀闯天下

考试加油站 发表于 2018-4-28 19:17
感谢帮忙，但对于我刚才发的附件是不成功的，有空请测试

户籍资料格式转换 (2)DD.zip (1.22 MB, 下载次数: 22)

2018-4-28 19:22 上传

点击文件名下载附件

你这模块中都没有代码，再不行我就认输了，挺想帮你但是觉得挺困难的。

考试加油站

一把小刀闯天下 发表于 2018-4-28 19:23
你这模块中都没有代码，再不行我就认输了，挺想帮你但是觉得挺困难的。

不好意思，麻烦您了，您看一下“张4”是第二户的成员，却排列到第一户后面了。

一把小刀闯天下

考试加油站 发表于 2018-4-28 20:08
不好意思，麻烦您了，您看一下“张4”是第二户的成员，却排列到第一户后面了。

按户号来排的？如果是这样相同户号的第一个人应该为户主，但是我看并不是这样的，不然处理起来会复杂很多。

If arr(j, 1) <> arr(j + 1, 1) Or Len(arr(j + 1, 3)) = 0 Then

一把小刀闯天下

考试加油站 发表于 2018-4-28 20:08
不好意思，麻烦您了，您看一下“张4”是第二户的成员，却排列到第一户后面了。

'加了户主位置判断，总用时<2s,可以接受，毕竟有44362条数据

Option Explicit

Sub test()
  Dim i, j, k, kk, arr, n, t, dt
  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
        If j > i And arr(j, 2) <> "户主" Then  '户主位置判断，同户号单人不做判断
          For k = i To j
            If arr(k, 2) = "户主" 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-29 05:28
'加了户主位置判断，总用时 i And arr(j, 2)  "户主" Then  '户主位置判断，同户号单人不做判断
        ...

非常感谢，51快乐.
测试结果如下：虽然按照户号排列，但如第一人不是户主，它依然排列在户主位置。

一把小刀闯天下

考试加油站 发表于 2018-4-29 11:03
非常感谢，51快乐.
测试结果如下：虽然按照户号排列，但如第一人不是户主，它依然排列在户主位置。

'可能户主单元格中有不可见字符？或者有空格？给你做了去空格处理，然后按包含来判断户主，再测试一下。
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(j, 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