感谢chxw68褚老师的帮助

iwangyi

好方法
Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 30))

chxw68

原始数据排列有序，不用字典也行。

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   With Worksheets("总表")
   
7.     r = .Cells(.Rows.Count, 27).End(xlUp).Row
   
8.     arr = .Range("aa1:aa" & r)
   
9.     xm = ""
   
10.     m = 0
    
11.     For i = 10 To UBound(arr)
    
12.       If arr(i, 1) <> xm Then
    
13.         m = m + 1
    
14.         ReDim Preserve zrr(1 To 2, 1 To m)
    
15.         zrr(1, m) = i
    
16.         zrr(2, m) = i
    
17.         xm = arr(i, 1)
    
18.       Else
    
19.         zrr(2, m) = i
    
20.       End If
    
21.     Next
    
22.   End With
    
23.   For k = 1 To UBound(zrr, 2)
    
24.     With Worksheets("模板")
    
25.       .Range("d3,f3,l3,a10:ad21") = ""
    
26.       Worksheets("总表").Cells(zrr(1, k), 1).Resize(zrr(2, k) - zrr(1, k) + 1, 30).Copy .Range("a10")
    
27.       .Range("d3") = "户编号：" & .Range("ad10")
    
28.       .Range("f3") = "户主姓名：" & .Range("b10")
    
29.       .Range("l3") = "组别：" & .Range("z10")
    
30.       wjm = .Range("aa10")
    
31.       .Copy
    
32.     End With
    
33.     With ActiveWorkbook
    
34.       With .Worksheets(1)
    
35.         .Name = wjm
    
36.       End With
    
37.       .SaveAs Filename:=ThisWorkbook.Path & "" & wjm
    
38.       .Close False
    
39.     End With
    
40.   Next
    
41. End Sub
    
42. 
    

复制代码

chxw68

一题两解。

hb-yy

chxw68 发表于 2018-9-16 09:08
详见附件。

太感谢了，

hb-yy

chxw68 发表于 2018-9-16 09:18
一题两解。

两种方法都非常完美。

dyh酋长

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

老师您好，我有一个问题关于按照表里面的主叫号码和数据库表里面的设备号字段，数据相匹配，然后导出数据库对应字段的序号、现负责人和业务员信息，现在的问题是数据小于6万条以下可以，超过6万就没反应或者报错，这个该怎么办，麻烦您可以帮我帮我看看，有没有什么办法解决，
http://club.excelhome.net/forum. ... p;page=1#pid9658458