户籍资料格式转换:一户多人多行排列成一户一行

考试加油站

户籍资料格式转换.rar (499.17 KB, 下载次数: 176)

2018-8-12 18:59 上传

点击文件名下载附件

xyxcc177

看你12年发一个一行转多行，现在又是一个多行转一行

zpy2

感觉还是搞个数据库，查询方便，不知为什么要这样转来转去的。

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i As Long, j As Long, k As Long, kk As Long, m As Long, n As Long
  With Sheets("原始表")
    i = .Cells(Rows.Count, "a").End(xlUp).Row
    j = .Cells(Rows.Count, "d").End(xlUp).Row
    arr = .Range("a3:e" & IIf(i > j, i, j) + 1)
    arr(UBound(arr, 1), 1) = "?"
  End With
  ReDim brr(1 To UBound(arr, 1), 1 To 40) As String
  For i = 1 To UBound(arr, 1)
    For j = i + 1 To UBound(arr, 1)
      If Len(arr(j, 1)) > 0 Then
        n = 0: m = m + 1
        For k = i To j - 1
          If k = i Then
            For kk = 1 To 3
              brr(m, kk) = arr(k, kk)
              n = n + 1
            Next
            If Len(arr(k, 4)) Then
              brr(m, 4) = arr(k, 4): brr(m, 5) = arr(k, 5)
              n = n + 2
            End If
          Else
            n = n + 2
            brr(m, n - 1) = arr(k, 4): brr(m, n) = arr(k, 5)
          End If
        Next
        i = j - 1: Exit For
      End If
  Next j, i
  With Sheets("转换后表").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    If m > 0 Then .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

考试加油站

一把小刀闯天下 发表于 2018-8-12 20:05
Option Explicit

Sub test()

非常感谢帮忙，马上测试，谢谢