求助如何将一张excel汇总表拆分成每个独立的excel文件

ohyeah9z

求助内容：
有一个汇总表表1

表1

，内有633行，有的村子不止一个人。
需要将每个人的数据，生成一个独立的excel文件表2，

表2

每个excel文件命名按照所在村的命名，把同一村的人放在同一个excel表里面。
由于数据量太大，手动很难完成，时间也比较紧张。
请帮忙解答！

ohyeah9z

请问这种需要用到什么方面的知识呢？

abc123281

呵呵   需要很多知识

abc123281

可以实现   等待结果

abc123281

我已经帮你写好了

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, 1).End(xlUp).Row
   
10.     arr = .Range("a2:j" & r)
    
11.     For i = 1 To UBound(arr)
    
12.       If Not d.exists(arr(i, 1)) Then
    
13.         m = 1
    
14.         ReDim brr(1 To 9, 1 To m)
    
15.       Else
    
16.         brr = d(arr(i, 1))
    
17.         m = UBound(brr, 2) + 1
    
18.         ReDim Preserve brr(1 To 9, 1 To m)
    
19.       End If
    
20.       For j = 2 To UBound(arr, 2)
    
21.         brr(j - 1, m) = arr(i, j)
    
22.       Next
    
23.       d(arr(i, 1)) = brr
    
24.     Next
    
25.   End With
    
26.   k = 0
    
27.   For Each aa In d.keys
    
28.     k = k + 1
    
29.     arr = d(aa)
    
30.     ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr))
    
31.     For i = 1 To UBound(arr)
    
32.       For j = 1 To UBound(arr, 2)
    
33.         brr(j, i) = arr(i, j)
    
34.       Next
    
35.     Next
    
36.     With Worksheets("模板")
    
37.       .Range("a8:i" & .Rows.Count).Clear
    
38.       .Range("d5") = aa
    
39.       .Range("a8").Resize(UBound(brr), UBound(brr, 2)) = brr
    
40.       r = UBound(brr) + 7
    
41.       .Range("a7:i" & r).Borders.LineStyle = xlContinuous
    
42.       With .UsedRange
    
43.         .HorizontalAlignment = xlCenter
    
44.         .VerticalAlignment = xlCenter
    
45.       End With
    
46.       .Copy
    
47.     End With
    
48.     With ActiveWorkbook
    
49.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
50.       .Close False
    
51.     End With
    
52.     If k = 2 Then
    
53.       Exit For
    
54.     End If
    
55.   Next
    
56.   Application.ScreenUpdating = True
    
57.   MsgBox "数据拆分完毕！"
    
58. End Sub
    

复制代码

chxw68

详见附件。

msnmurong

chxw68 发表于 2018-3-17 09:58
详见附件。

老师,我看这个表和我求助的有点类似,只不过我的不是一行的表头,还有向下的。能帮我看看如何实现吗https://club.excelhome.net/forum ... ;page=1#pid11140118