[已解决]相同名称下的内容增加

guolianjd

怎样把Sheet2第四行插入到Sheet1同户主名下，也就是说把新增的人插入相同的户主名下

工作表 (2).rar (10.23 KB, 下载次数: 4)

2016-9-10 21:49 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

雨吧

2016-9-10 22:32

guolianjd 发表于 2016-9-10 21:47
不好意思是我把数据复制重复了，也就是说把2表新增的人插入1表相同的户主的名下，附件已重新上传

既然忽略第2个问题，那就以示例结果为准，
以下代码楼主测试：

1. Sub YuBa()
   
2.     Dim d As Object, arr(1), brr(1 To 10000, 1 To 8), s$, m%, n%, i%, j%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr(0) = Sheet2.UsedRange
   
5.     With Sheet1
   
6.         arr(1) = .Range("a2").CurrentRegion
   
7.         For i = 1 To UBound(arr(0))
   
8.             If arr(0)(i, 4) = "户主" Then s = arr(0)(i, 5)
   
9.             If arr(0)(i, 8) = "新增" Then
   
10.                 If d.exists(s) Then
    
11.                     d(s) = d(s) & " " & i
    
12.                 Else
    
13.                     d(s) = i
    
14.                 End If
    
15.             End If
    
16.         Next
    
17.         For i = 1 To UBound(arr(1))
    
18.             n = n + 1
    
19.             If arr(1)(i, 4) = "户主" Then s = arr(1)(i, 5)
    
20.             For j = 1 To 8
    
21.                 brr(n, j) = arr(1)(i, j)
    
22.             Next
    
23.             If i < UBound(arr(1)) Then
    
24.                 If arr(1)(i + 1, 4) = "户主" Then
    
25.                     If d.exists(s) Then
    
26.                         ar = Split(d(s))
    
27.                         For m = 0 To UBound(ar)
    
28.                             n = n + 1
    
29.                             For j = 1 To 8
    
30.                                 brr(n, j) = arr(0)(ar(m), j)
    
31.                             Next
    
32.                         Next
    
33.                     End If
    
34.                 End If
    
35.             End If
    
36.         Next
    
37.         .[t2:aa999] = ""
    
38.         .[t2].Resize(n, 8) = brr
    
39.     End With
    
40. End Sub
    

复制代码

工作表 (2).rar (20.73 KB, 下载次数: 5)

2016-9-10 22:32 上传

点击文件名下载附件

跳转到最佳答案楼层

lmze2000

感觉你的问题，没有啥太大的实际意义呢，，
你sheet2里面的内容，就是你新增完的啊，就是多了一个序号。其余的都没有变化啊。

雨吧

楼主很惜文字，为何不对添加规则简单说明一下。
看了结果表有两个问题不是很明确：

1、源表中有“户主”重名的，Sheet2表中有“新增”，添加规则是什么，比如源表的第1、8行。
2、Sheet2表中有“新增”户主，成员却有“新增”和无“新增”字样的，令人匪夷所思。按道理“新增”户主了所有成员都应该是“新增”的。这样户主和成员不添加吗（楼主的结果表未有见新增户主）？比如Sheet2表的19行。

guolianjd

雨吧 发表于 2016-9-10 20:22
楼主很惜文字，为何不对添加规则简单说明一下。
看了结果表有两个问题不是很明确：

不好意思是我把数据复制重复了，也就是说把2表新增的人插入1表相同的户主的名下，附件已重新上传

guolianjd

lmze2000 发表于 2016-9-10 20:09
感觉你的问题，没有啥太大的实际意义呢，，
你sheet2里面的内容，就是你新增完的啊，就是多了一个序号。其 ...

一样吗？Sheet2中的E2到E5，Sheet1中的E2到E4，一样吗？也就是说把Sheet2新增的人插入Sheet1相同的户主名下

lmze2000

guolianjd 发表于 2016-9-10 21:56
一样吗？Sheet2中的E2到E5，Sheet1中的E2到E4，一样吗？也就是说把Sheet2新增的人插入Sheet1相同的户主名 ...

sheet2中新增的人员，在sheet1中复制插入之后，不就和sheet2中的是一样的了吗?
不知道这样理解对不对。

guolianjd

lmze2000 发表于 2016-9-10 22:06
sheet2中新增的人员，在sheet1中复制插入之后，不就和sheet2中的是一样的了吗?
不知道这样理解对不对。

是的，几千条数据剪切很麻烦的的，不知道有么有代码

雨吧

guolianjd 发表于 2016-9-10 21:47
不好意思是我把数据复制重复了，也就是说把2表新增的人插入1表相同的户主的名下，附件已重新上传

既然忽略第2个问题，那就以示例结果为准，
以下代码楼主测试：

1. Sub YuBa()
   
2.     Dim d As Object, arr(1), brr(1 To 10000, 1 To 8), s$, m%, n%, i%, j%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr(0) = Sheet2.UsedRange
   
5.     With Sheet1
   
6.         arr(1) = .Range("a2").CurrentRegion
   
7.         For i = 1 To UBound(arr(0))
   
8.             If arr(0)(i, 4) = "户主" Then s = arr(0)(i, 5)
   
9.             If arr(0)(i, 8) = "新增" Then
   
10.                 If d.exists(s) Then
    
11.                     d(s) = d(s) & " " & i
    
12.                 Else
    
13.                     d(s) = i
    
14.                 End If
    
15.             End If
    
16.         Next
    
17.         For i = 1 To UBound(arr(1))
    
18.             n = n + 1
    
19.             If arr(1)(i, 4) = "户主" Then s = arr(1)(i, 5)
    
20.             For j = 1 To 8
    
21.                 brr(n, j) = arr(1)(i, j)
    
22.             Next
    
23.             If i < UBound(arr(1)) Then
    
24.                 If arr(1)(i + 1, 4) = "户主" Then
    
25.                     If d.exists(s) Then
    
26.                         ar = Split(d(s))
    
27.                         For m = 0 To UBound(ar)
    
28.                             n = n + 1
    
29.                             For j = 1 To 8
    
30.                                 brr(n, j) = arr(0)(ar(m), j)
    
31.                             Next
    
32.                         Next
    
33.                     End If
    
34.                 End If
    
35.             End If
    
36.         Next
    
37.         .[t2:aa999] = ""
    
38.         .[t2].Resize(n, 8) = brr
    
39.     End With
    
40. End Sub
    

复制代码

工作表 (2).rar (20.73 KB, 下载次数: 5)

2016-9-10 22:32 上传

点击文件名下载附件

guolianjd

雨吧 发表于 2016-9-10 22:32
既然忽略第2个问题，那就以示例结果为准，
以下代码楼主测试：

谢谢，搞定