感谢chxw68褚老师的帮助

hb-yy

感谢chxw68褚老师的帮助，已完美解决

lsc900707

还真不是难事，找找拆分的实例稍加修改就行。

hb-yy

不会。摸索摸索感觉一塌糊涂

chxw68

hb-yy 发表于 2018-9-15 19:23
不会。摸索摸索感觉一塌糊涂

是拆分成多簿多表吧？也就是每个组拆分为一个工作簿，每户拆分为一个工作表？

hb-yy

chxw68 发表于 2018-9-15 22:14
是拆分成多簿多表吧？也就是每个组拆分为一个工作簿，每户拆分为一个工作表？

谢谢关注。是的拆分多簿。加一条表尾加一固定行

chxw68

hb-yy 发表于 2018-9-16 08:14
谢谢关注。是的拆分多簿。加一条表尾加一固定行

楼主能分清工作簿和工作表吗？是一个组一个工作簿也就是一个独立的.xlsx文件，比如1组；然后该组里人员每户一个工作表，也就是一个SHEET，比如：秦XX、李XX、陈XX？

chxw68

实在不解！怎么按Z列拆分，又按AA列内容名命？比如Z列内容“1组”对应的AA列内容就有“秦XX”、“李XX”、“陈XX”，那么到底按哪个命名呢？

hb-yy

chxw68 发表于 2018-9-16 08:32
实在不解！怎么按Z列拆分，又按AA列内容名命？比如Z列内容“1组”对应的AA列内容就有“秦XX”、“李XX”、 ...

对不起，插了一列 按AA列分

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("总表")
   
9.     r = .Cells(.Rows.Count, 27).End(xlUp).Row
   
10.     arr = .Range("aa1:aa" & r)
    
11.     For i = 10 To UBound(arr)
    
12.       If Not d.exists(arr(i, 1)) Then
    
13.         Set d(arr(i, 1)) = .Cells(i, 1).Resize(1, 30)
    
14.       Else
    
15.         Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 30))
    
16.       End If
    
17.     Next
    
18.   End With
    
19.   For Each aa In d.keys
    
20.     With Worksheets("模板")
    
21.       .Range("d3,f3,l3,a10:ad21") = ""
    
22.       d(aa).Copy .Range("a10")
    
23.       .Range("d3") = "户编号：" & .Range("ad10")
    
24.       .Range("f3") = "户主姓名：" & .Range("b10")
    
25.       .Range("l3") = "组别：" & .Range("z10")
    
26.       .Copy
    
27.     End With
    
28.     With ActiveWorkbook
    
29.       With .Worksheets(1)
    
30.         .Name = aa
    
31.       End With
    
32.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
33.       .Close False
    
34.     End With
    
35.   Next
    
36. End Sub
    

复制代码

chxw68

详见附件。