请各位大虾帮下忙，为每一户新建立一个工作表，并拷贝进去姓名

fresal

实现目的：1.根据表一建立以“户表”为模板的新工作表，新表名为户主姓名
2.把同一户的所有的人的姓名、身份证号码，从表一拷贝进以该户户主为名字的新表。


请各位大大帮下忙，谢谢了，不然上千户要分出来每户做，要疯掉的。我的vba能实现每个人建一张表，但不能分户建表。

fresal

由于有点急，顶一下

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   m = 0
   
5.   With Worksheets("基础数据")
   
6.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
7.     arr = .Range("a4:d" & r)
   
8.     For i = 1 To UBound(arr)
   
9.       If arr(i, 3) = "户主" Then
   
10.         m = m + 1
    
11.         ReDim Preserve zrr(1 To 2, 1 To m)
    
12.         zrr(1, m) = i
    
13.         zrr(2, m) = i
    
14.       Else
    
15.         zrr(2, m) = i
    
16.       End If
    
17.     Next
    
18.   End With
    
19.   For Each ws In Worksheets
    
20.     If ws.Name <> "基础数据" And ws.Name <> "户表" Then
    
21.       ws.Delete
    
22.     End If
    
23.   Next
    
24.   For k = 1 To UBound(zrr, 2)
    
25.     Worksheets("户表").Copy after:=Worksheets(Worksheets.Count)
    
26.     With ActiveSheet
    
27.       .Name = arr(zrr(1, k), 2)
    
28.       m = 0
    
29.       For i = zrr(1, k) To zrr(2, k)
    
30.         m = m + 1
    
31.         .Cells(m + 5, 2) = arr(i, 2)
    
32.         .Cells(m + 5, 3) = arr(i, 4)
    
33.         .Cells(m + 21, 2) = arr(i, 2)
    
34.         .Cells(m + 21, 3) = arr(i, 4)
    
35.         .Cells(m + 36, 2) = arr(i, 2)
    
36.         .Cells(m + 36, 3) = arr(i, 4)
    
37.       Next
    
38.     End With
    
39.   Next
    
40. End Sub
    

复制代码

chxw68

户主不能有重名的。

fresal

非常感谢，由于基础数据还没有完全弄好，几户测试可用，弄好基础数据在全部生成看下，已经是非常感谢了

yaojil

最后一张表会报错，但应该已实现

fresal

yaojil 发表于 2018-6-15 19:01
最后一张表会报错，但应该已实现

谢谢了您的帮助。