户籍资料格式转换 (2)

考试加油站 · 发表于 2018-4-26 13:20

本帖最后由考试加油站于 2018-4-28 21:31 编辑

户籍资料格式转换 (2)DD.rar (742.97 KB, 下载次数: 40)

ホ随ヴ风ㄉ · 发表于 2018-4-26 13:49

你的问题并不是只户主有一个的时候不行，而是只要是户主的时候就没取进去。

请参考以下代码：

Option Explicit
Sub test()
Dim arr, i&, m&, r&
With Sheet1
r = .Cells(Rows.Count, 4).End(3).Row
arr = .Range("A2:E" & r)
End With
ReDim brr(1 To UBound(arr), 1 To 5)
m = 1
For i = 1 To UBound(arr)
If arr(i, 2) = "户主" Then
brr(m, 1) = arr(i, 5)
brr(m, 2) = arr(i, 3)
brr(m, 3) = arr(i, 4)
brr(m, 4) = arr(i, 3)
brr(m, 5) = arr(i, 4)
m = m + 1
Else
brr(m, 4) = arr(i, 3)
brr(m, 5) = arr(i, 4)
m = m + 1
End If
Next
With Sheet2.[a3]
.CurrentRegion.Offset(3).ClearContents
.Resize(m - 1, 5) = brr
End With
End Sub

复制代码

考试加油站 · 发表于 2018-4-26 13:56

本帖最后由考试加油站于 2018-4-26 14:04 编辑

ホ随ヴ风ㄉ发表于 2018-4-26 13:49
你的问题并不是只户主有一个的时候不行，而是只要是户主的时候就没取进去。

请参考以下代码：

这样的话，当第一行家庭只有一口人时，在家庭成员栏应当是空白，却被重复写了一次，如何修改 QQ截图20180426140136.png

一把小刀闯天下 · 发表于 2018-4-26 14:06

Option Explicit

Sub test()
  Dim i, j, k, arr, n
  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 Len(arr(j + 1, 2)) > 0 Or Len(arr(j + 1, 3)) = 0 Then
      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)
         Else
            Exit For
         End If
         k = k + 1
      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
  With Sheets("转换后生成的表").[a3]
.Resize(Rows.Count - 2, UBound(arr, 2)).ClearContents
.Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

考试加油站 · 发表于 2018-4-26 14:12

本帖最后由考试加油站于 2018-4-26 14:17 编辑

一把小刀闯天下发表于 2018-4-26 14:06
Option Explicit

Sub test()

谢谢，这样应当不行，全部写入到户主栏了，家庭人口栏全部空白，我用40000行数据测试，全是这样。

考试加油站 · 发表于 2018-4-26 14:32

本帖最后由考试加油站于 2018-4-26 15:02 编辑

一把小刀闯天下发表于 2018-4-26 14:06
Option Explicit

Sub test()

谢谢，基本成功了，但如在与户主关系栏写上“户主，妻子，儿子，次子，子等常见内容时会出错”，If Len(arr(j + 1, 2)) > 0 Or Len(arr(j + 1, 3)) = 0 这句话如何理解

一把小刀闯天下 · 发表于 2018-4-26 14:35

考试加油站发表于 2018-4-26 14:32
谢谢，成功了，If Len(arr(j + 1, 2)) > 0 Or Len(arr(j + 1, 3)) = 0 这句话如何理解

偷懒的写法，跟前面的.row+1配合使用，这样代码可以少写几行，但理解起来可能有点费劲，自己好好琢磨一下。满意来朵小花哈。

ホ随ヴ风ㄉ · 发表于 2018-4-26 14:36

Option Explicit
Sub test()
Dim arr, i&, m&, r&
With Sheet1
r = .Cells(Rows.Count, 4).End(3).Row
arr = .Range("A2:E" & r)
End With
ReDim brr(1 To UBound(arr), 1 To 5)
m = 1
For i = 1 To UBound(arr)
If arr(i, 2) = "户主" Then
brr(m, 1) = arr(i, 5)
brr(m, 2) = arr(i, 3)
brr(m, 3) = arr(i, 4)
'brr(m, 4) = arr(i, 3) 去掉这行
'brr(m, 5) = arr(i, 4) 这行也去掉就行了
m = m + 1
Else
brr(m, 4) = arr(i, 3)
brr(m, 5) = arr(i, 4)
m = m + 1
End If
Next
With Sheet2.[a3]
.CurrentRegion.Offset(3).ClearContents
.Resize(m - 1, 5) = brr
End With
End Sub

复制代码

考试加油站 · 发表于 2018-4-26 14:53

本帖最后由考试加油站于 2018-4-26 15:00 编辑

ホ随ヴ风ㄉ发表于 2018-4-26 14:36

谢谢，这样写，当家庭人口超过1人时，在家庭人口栏又多了一空行 QQ截图20180426145657.png

opiona · 发表于 2018-4-26 15:47

Sub opiona()
Set SH1 = Worksheets("数据库原表")
Set SH2 = Worksheets("转换后生成的表")
SH2.Range("A3:E65536").ClearContents
LASTROW = 3
For IROW = 2 To SH1.Range("A65536").End(3).Row
If SH1.Cells(IROW, 2).Value = "户主" Then
SH2.Cells(LASTROW, 1).Value = SH1.Cells(IROW, 5).Value
SH2.Cells(LASTROW, 2).Value = SH1.Cells(IROW, 3).Value
SH2.Cells(LASTROW, 3).Value = SH1.Cells(IROW, 4).Value
Rem 如果2个户主挨着，填写成员后加一行
If SH1.Cells(IROW + 1, 2).Value = "户主" Then
' Rem 如果要求单人户主成员信息空白，则删除下2行
' SH2.Cells(LASTROW, 4).Value = SH1.Cells(IROW, 3).Value
' SH2.Cells(LASTROW, 5).Value = SH1.Cells(IROW, 4).Value
LASTROW = LASTROW + 1
End If
Else
SH2.Cells(LASTROW, 4).Value = SH1.Cells(IROW, 3).Value
SH2.Cells(LASTROW, 5).Value = SH1.Cells(IROW, 4).Value
LASTROW = LASTROW + 1
End If
Next
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 户籍资料格式转换 (2)

评分