[已解决]求救，批量复制配偶相关信息，上下行不对应那种。

spider2

刚才发的好像看不到。重发次。恳请高手帮忙。。。不胜感激。。。。

XK0oUghY.rar (2.2 KB, 下载次数: 6)

2010-9-7 03:43 上传

点击文件名下载附件
求救，批量复制配偶相关信息，上下行不对应那种。

以户编码为单位。每个编码一户人，要求将配偶和父母信息（姓名+证件号码）要一一对应。批量操作。有高手编个函数并附上操作步骤吗？我是表格新手。。。参照网上资料用VLOOKUP函数弄不出来。不是出错就是不对应。。。

[em39]

最佳答案

月排行榜 / 总排行榜

wayy

2010-9-7 14:19

Sub wayy()
Dim arr1, arr2
Dim x, y, mrow As Long
[J2:O65536].ClearContents
Application.ScreenUpdating = False
arr1 = Range("A2", [I65536].End(xlUp))
ReDim arr2(1 To UBound(arr1), 1 To 6)
For x = 1 To UBound(arr1)
 If arr1(x, 8) = "子" Or arr1(x, 8) = "女" Then
   For y = x + 1 To UBound(arr1)
     If arr1(y, 9) = arr1(x, 9) Then
       If arr1(y, 8) = "户主" Then
        arr2(x, 3) = arr1(y, 2)
        arr2(x, 4) = arr1(y, 4)
       ElseIf arr1(y, 8) = "配偶" Then
        arr2(x, 5) = arr1(y, 2)
        arr2(x, 6) = arr1(y, 4)
       End If
     Else
       GoTo 100
     End If
   Next
100:
Else
   If arr1(x, 8) = "户主" Then
       For y = x + 1 To UBound(arr1)
          If arr1(y, 9) = arr1(x, 9) Then
            If arr1(y, 8) = "配偶" Then
             arr2(x, 1) = arr1(y, 2)
             arr2(x, 2) = arr1(y, 4)
             arr2(y, 1) = arr1(x, 2)
             arr2(y, 2) = arr1(x, 4)
            End If
          Else
            GoTo 200
          End If
       Next
  End If
200:
    If arr1(x, 8) = "配偶" Then
       For y = x + 1 To UBound(arr1)
          If arr1(y, 9) = arr1(x, 9) Then
            If arr1(y, 8) = "户主" Then
              arr2(x, 1) = arr1(y, 2)
              arr2(x, 2) = arr1(y, 4)
              arr2(y, 1) = arr1(x, 2)
              arr2(y, 2) = arr1(x, 4)
            End If
          Else
           GoTo 300
          End If
       Next
    End If
300:

End If
Next
[j2].Resize(UBound(arr1), 6) = arr2
Application.ScreenUpdating = True
MsgBox "OK", , "wayy"
End Sub

代码写了一个，应该可以。

[此贴子已经被作者于2010-9-7 14:23:45编辑过]

跳转到最佳答案楼层

spider2

我的QQ110745948或者发邮件给我都可以。等待高手解救。。。。

wayy

gbgO8SmP.rar (3.82 KB, 下载次数: 6)

2010-9-7 08:33 上传

点击文件名下载附件
求救，批量复制配偶相关信息，上下行不对应那种。

每列一个公式，将就用吧。

lxx822

我怎么就没有想到用SUMPRODUCT呢！

spider2

还是不行啊。有没有函数的解析啊。我代入正确的数据时全部数据就出错。而且。我选取一段数据粘贴进去，也不行。不知道怎么回事。可能是我太笨了吧。能再指导一下吗？我的证件号码是15或18位的身份证。编码也是18位的数字。是不是因为这个出错啊？

spider2

在线等待高手。。。。

wayy

Sub wayy()
Dim arr1, arr2
Dim x, y, mrow As Long
[J2:O65536].ClearContents
Application.ScreenUpdating = False
arr1 = Range("A2", [I65536].End(xlUp))
ReDim arr2(1 To UBound(arr1), 1 To 6)
For x = 1 To UBound(arr1)
 If arr1(x, 8) = "子" Or arr1(x, 8) = "女" Then
   For y = x + 1 To UBound(arr1)
     If arr1(y, 9) = arr1(x, 9) Then
       If arr1(y, 8) = "户主" Then
        arr2(x, 3) = arr1(y, 2)
        arr2(x, 4) = arr1(y, 4)
       ElseIf arr1(y, 8) = "配偶" Then
        arr2(x, 5) = arr1(y, 2)
        arr2(x, 6) = arr1(y, 4)
       End If
     Else
       GoTo 100
     End If
   Next
100:
Else
   If arr1(x, 8) = "户主" Then
       For y = x + 1 To UBound(arr1)
          If arr1(y, 9) = arr1(x, 9) Then
            If arr1(y, 8) = "配偶" Then
             arr2(x, 1) = arr1(y, 2)
             arr2(x, 2) = arr1(y, 4)
             arr2(y, 1) = arr1(x, 2)
             arr2(y, 2) = arr1(x, 4)
            End If
          Else
            GoTo 200
          End If
       Next
  End If
200:
    If arr1(x, 8) = "配偶" Then
       For y = x + 1 To UBound(arr1)
          If arr1(y, 9) = arr1(x, 9) Then
            If arr1(y, 8) = "户主" Then
              arr2(x, 1) = arr1(y, 2)
              arr2(x, 2) = arr1(y, 4)
              arr2(y, 1) = arr1(x, 2)
              arr2(y, 2) = arr1(x, 4)
            End If
          Else
           GoTo 300
          End If
       Next
    End If
300:

End If
Next
[j2].Resize(UBound(arr1), 6) = arr2
Application.ScreenUpdating = True
MsgBox "OK", , "wayy"
End Sub

代码写了一个，应该可以。

[此贴子已经被作者于2010-9-7 14:23:45编辑过]

spider2

嗯。嗯。谢谢。。。终于解决了。感激。。。。最近正在抓紧学习。。书到用时方恨少啊。现在正在弄怎么根据出生日期生成18位身份证号码。而且第18位要符合检验。。。正在盲目地弄。有好办法吗？？