[已解决]怎样根据某字段创建工作簿、工作表

特大暴风雨

我想根据小渔镇工作簿中“农户基础信息明细表”的H列中的村名作为新工作簿名并在此工作簿根据组别分组建工作表，再把“农户基础信息表”中的内容分村分组复制到这些村组工作簿、工作表，请教各位高手我用代码怎样实现？还有工作簿有没有name属性？怎样根据需要动态获取工作簿名？

最佳答案

月排行榜 / 总排行榜

桀骜孤星

2012-5-4 22:27

终于搞定了，运行时间有点长

1. 
   
2. Sub 分解()
   
3. Dim crr(1 To 1500, 1 To 8)
   
4. Set yyy = CreateObject("Scripting.FileSystemObject")
   
5.    
   
6. If yyy.FolderExists(ThisWorkbook.Path & "\各村") = False Then
   
7.     Set aaa = CreateObject("Scripting.FileSystemObject")
   
8.     aaa.CreateFolder ThisWorkbook.Path & "\各村"
   
9.     End If
   
10. Set d = CreateObject("scripting.dictionary")
    
11. 
    
12. 
    
13. 
    
14. 
    
15. arr = ThisWorkbook.Sheets("农户基础信息明细表").Range("a2:h" & ThisWorkbook.Sheets("农户基础信息明细表").[h65536].End(3).Row)
    
16. 
    
17. For i = 1 To UBound(arr)
    
18. d(Left(arr(i, 8), Len(arr(i, 8)) - 2)) = ""
    
19. Next
    
20. arrcm = d.keys
    
21. d.RemoveAll
    
22. 
    
23. For i = 0 To UBound(arrcm)
    
24. Set wb = Workbooks.Add
    
25. wb.SaveAs Filename:=ThisWorkbook.Path & "\各村" & Right(arrcm(i), Len(arrcm(i)) - 2), FileFormat:=xlExcel8
    
26. 50:
    
27. j = j + 1
    
28. 
    
29. If j = UBound(arr) Then
    
30. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
31. c = c + 1
    
32. For k = 1 To 8
    
33. crr(c, k) = arr(j, k)
    
34. Next
    
35. End If
    
36. 
    
37. Sheets.Add after:=Sheets(Sheets.Count)
    
38. ActiveSheet.Name = Right(arr(j, 8), 2)
    
39. ThisWorkbook.Sheets(1).Range("a1:h1").Copy
    
40. wb.Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteAll
    
41. 
    
42. wb.Sheets(Sheets.Count).[a1].PasteSpecial Paste:=xlPasteColumnWidths
    
43. 
    
44. wb.Sheets(Sheets.Count).[a2].Resize(c, 8) = crr
    
45. 
    
46. c = 0
    
47. Erase crr
    
48. 
    
49. GoTo 100
    
50. End If
    
51. 
    
52. 
    
53. 
    
54. If (j <> 1 And Right(arr(j, 8), 2) <> Right(arr(j + 1, 8), 2)) Then
    
55. 
    
56. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
57. c = c + 1
    
58. For k = 1 To 8
    
59. crr(c, k) = arr(j, k)
    
60. Next
    
61. End If
    
62. 
    
63. Sheets.Add after:=Sheets(Sheets.Count)
    
64. ActiveSheet.Name = Right(arr(j, 8), 2)
    
65. ThisWorkbook.Sheets(1).Range("a1:h1").Copy
    
66. wb.Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteAll
    
67. 
    
68. wb.Sheets(Sheets.Count).[a1].PasteSpecial Paste:=xlPasteColumnWidths
    
69. 
    
70. wb.Sheets(Sheets.Count).[a2].Resize(c, 8) = crr
    
71. 
    
72. c = 0
    
73. Erase crr
    
74. 
    
75. If Left(arr(j + 1, 8), Len(arr(j + 1, 8)) - 2) <> arrcm(i) Then GoTo 100
    
76. 
    
77. Else
    
78. 
    
79. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
80. 
    
81. 
    
82. c = c + 1
    
83. For k = 1 To 8
    
84. crr(c, k) = arr(j, k)
    
85. Next
    
86. 
    
87. 
    
88. End If
    
89. End If
    
90. 
    
91. If j = UBound(arr) Then
    
92. wb.Close True
    
93. Else
    
94. GoTo 50
    
95. End If
    
96. 100:
    
97. wb.Close True
    
98. Next
    
99. End Sub
    
100. 
     
101. 
     
102. 
     

复制代码

小渔镇.rar (247.67 KB, 下载次数: 72)

2012-5-4 22:27 上传

点击文件名下载附件

跳转到最佳答案楼层

HowyHuang

哎，公司里面屏蔽了RAR文件，真烦...
思路是 ，先循环遍历H列取单元格值，然后将取到的值赋值给新建的工作表，然后查找对应村组的所有信息，然后看你安排的格式，放入对应村组的工作表中...

特大暴风雨

HowyHuang 发表于 2012-5-4 10:12
哎，公司里面屏蔽了RAR文件，真烦...
思路是 ，先循环遍历H列取单元格值，然后将取到的值赋值给新建的工作 ...

并且要把内容复制到按村名命名的工作簿的不同组里面

桀骜孤星

写了半天，还没写完，晚上再想下

桀骜孤星

第一个村是正常了，第二个村出现错误，我再想下

1. 
   
2. Sub 分解()
   
3. Dim crr(1 To 1500, 1 To 8)
   
4. Set yyy = CreateObject("Scripting.FileSystemObject")
   
5.    
   
6. If yyy.FolderExists(ThisWorkbook.Path & "\各村") = False Then
   
7.     Set aaa = CreateObject("Scripting.FileSystemObject")
   
8.     aaa.CreateFolder ThisWorkbook.Path & "\各村"
   
9.     End If
   
10. Set d = CreateObject("scripting.dictionary")
    
11. 
    
12. 
    
13. 
    
14. 
    
15. arr = ThisWorkbook.Sheets("农户基础信息明细表").Range("a2:h" & ThisWorkbook.Sheets("农户基础信息明细表").[h65536].End(3).Row)
    
16. 
    
17. For i = 1 To UBound(arr)
    
18. d(Left(arr(i, 8), Len(arr(i, 8)) - 2)) = ""
    
19. Next
    
20. arrcm = d.keys
    
21. d.RemoveAll
    
22. 
    
23. For i = 0 To UBound(arrcm)
    
24. Set wb = Workbooks.Add
    
25. wb.SaveAs Filename:=ThisWorkbook.Path & "\各村" & Right(arrcm(i), Len(arrcm(i)) - 2), FileFormat:=xlExcel8
    
26. 
    
27. For j = 1 To UBound(arr)
    
28. If j <> 1 And Right(arr(j, 8), 2) <> Right(arr(j + 1, 8), 2) Then
    
29. 
    
30. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
31. c = c + 1
    
32. For k = 1 To 8
    
33. crr(c, k) = arr(j, k)
    
34. Next
    
35. End If
    
36. 
    
37. Sheets.Add after:=Sheets(Sheets.Count)
    
38. ActiveSheet.Name = Right(arr(j, 8), 2)
    
39. ThisWorkbook.Sheets(1).Range("a1:h1").Copy
    
40. wb.Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteAll
    
41. 
    
42. wb.Sheets(Sheets.Count).[a1].PasteSpecial Paste:=xlPasteColumnWidths
    
43. 
    
44. wb.Sheets(Sheets.Count).[a2].Resize(c, 8) = crr
    
45. 
    
46. c = 0
    
47. Erase crr
    
48. 
    
49. If Left(arr(j + 1, 8), Len(arr(j + 1, 8)) - 2) <> arrcm(i) Then GoTo 100
    
50. 
    
51. Else
    
52. 
    
53. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
54. 
    
55. 
    
56. c = c + 1
    
57. For k = 1 To 8
    
58. crr(c, k) = arr(j, k)
    
59. Next
    
60. 
    
61. 
    
62. End If
    
63. End If
    
64. 
    
65. Next
    
66. 
    
67. 100:
    
68. wb.Close True
    
69. Next
    
70. End Sub
    
71. 
    
72. 
    
73. 
    

复制代码

桀骜孤星

最后一个村的最后一个组手动下，别的都可以了

1. 
   
2. Sub 分解()
   
3. Dim crr(1 To 1500, 1 To 8)
   
4. Set yyy = CreateObject("Scripting.FileSystemObject")
   
5.    
   
6. If yyy.FolderExists(ThisWorkbook.Path & "\各村") = False Then
   
7.     Set aaa = CreateObject("Scripting.FileSystemObject")
   
8.     aaa.CreateFolder ThisWorkbook.Path & "\各村"
   
9.     End If
   
10. Set d = CreateObject("scripting.dictionary")
    
11. 
    
12. 
    
13. 
    
14. 
    
15. arr = ThisWorkbook.Sheets("农户基础信息明细表").Range("a2:h" & ThisWorkbook.Sheets("农户基础信息明细表").[h65536].End(3).Row)
    
16. 
    
17. For i = 1 To UBound(arr)
    
18. d(Left(arr(i, 8), Len(arr(i, 8)) - 2)) = ""
    
19. Next
    
20. arrcm = d.keys
    
21. d.RemoveAll
    
22. 
    
23. For i = 0 To UBound(arrcm)
    
24. Set wb = Workbooks.Add
    
25. wb.SaveAs Filename:=ThisWorkbook.Path & "\各村" & Right(arrcm(i), Len(arrcm(i)) - 2), FileFormat:=xlExcel8
    
26. 50:
    
27. j = j + 1
    
28. If j <> 1 And Right(arr(j, 8), 2) <> Right(arr(j + 1, 8), 2) Then
    
29. 
    
30. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
31. c = c + 1
    
32. For k = 1 To 8
    
33. crr(c, k) = arr(j, k)
    
34. Next
    
35. End If
    
36. 
    
37. Sheets.Add after:=Sheets(Sheets.Count)
    
38. ActiveSheet.Name = Right(arr(j, 8), 2)
    
39. ThisWorkbook.Sheets(1).Range("a1:h1").Copy
    
40. wb.Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteAll
    
41. 
    
42. wb.Sheets(Sheets.Count).[a1].PasteSpecial Paste:=xlPasteColumnWidths
    
43. 
    
44. wb.Sheets(Sheets.Count).[a2].Resize(c, 8) = crr
    
45. 
    
46. c = 0
    
47. Erase crr
    
48. 
    
49. If Left(arr(j + 1, 8), Len(arr(j + 1, 8)) - 2) <> arrcm(i) Then GoTo 100
    
50. 
    
51. Else
    
52. 
    
53. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
54. 
    
55. 
    
56. c = c + 1
    
57. For k = 1 To 8
    
58. crr(c, k) = arr(j, k)
    
59. Next
    
60. 
    
61. 
    
62. End If
    
63. End If
    
64. 
    
65. If j = UBound(arr) Then
    
66. wb.Close True
    
67. Else
    
68. GoTo 50
    
69. End If
    
70. 100:
    
71. wb.Close True
    
72. Next
    
73. End Sub
    
74. 
    
75. 
    
76. 
    

复制代码

桀骜孤星

终于搞定了，运行时间有点长

1. 
   
2. Sub 分解()
   
3. Dim crr(1 To 1500, 1 To 8)
   
4. Set yyy = CreateObject("Scripting.FileSystemObject")
   
5.    
   
6. If yyy.FolderExists(ThisWorkbook.Path & "\各村") = False Then
   
7.     Set aaa = CreateObject("Scripting.FileSystemObject")
   
8.     aaa.CreateFolder ThisWorkbook.Path & "\各村"
   
9.     End If
   
10. Set d = CreateObject("scripting.dictionary")
    
11. 
    
12. 
    
13. 
    
14. 
    
15. arr = ThisWorkbook.Sheets("农户基础信息明细表").Range("a2:h" & ThisWorkbook.Sheets("农户基础信息明细表").[h65536].End(3).Row)
    
16. 
    
17. For i = 1 To UBound(arr)
    
18. d(Left(arr(i, 8), Len(arr(i, 8)) - 2)) = ""
    
19. Next
    
20. arrcm = d.keys
    
21. d.RemoveAll
    
22. 
    
23. For i = 0 To UBound(arrcm)
    
24. Set wb = Workbooks.Add
    
25. wb.SaveAs Filename:=ThisWorkbook.Path & "\各村" & Right(arrcm(i), Len(arrcm(i)) - 2), FileFormat:=xlExcel8
    
26. 50:
    
27. j = j + 1
    
28. 
    
29. If j = UBound(arr) Then
    
30. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
31. c = c + 1
    
32. For k = 1 To 8
    
33. crr(c, k) = arr(j, k)
    
34. Next
    
35. End If
    
36. 
    
37. Sheets.Add after:=Sheets(Sheets.Count)
    
38. ActiveSheet.Name = Right(arr(j, 8), 2)
    
39. ThisWorkbook.Sheets(1).Range("a1:h1").Copy
    
40. wb.Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteAll
    
41. 
    
42. wb.Sheets(Sheets.Count).[a1].PasteSpecial Paste:=xlPasteColumnWidths
    
43. 
    
44. wb.Sheets(Sheets.Count).[a2].Resize(c, 8) = crr
    
45. 
    
46. c = 0
    
47. Erase crr
    
48. 
    
49. GoTo 100
    
50. End If
    
51. 
    
52. 
    
53. 
    
54. If (j <> 1 And Right(arr(j, 8), 2) <> Right(arr(j + 1, 8), 2)) Then
    
55. 
    
56. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
57. c = c + 1
    
58. For k = 1 To 8
    
59. crr(c, k) = arr(j, k)
    
60. Next
    
61. End If
    
62. 
    
63. Sheets.Add after:=Sheets(Sheets.Count)
    
64. ActiveSheet.Name = Right(arr(j, 8), 2)
    
65. ThisWorkbook.Sheets(1).Range("a1:h1").Copy
    
66. wb.Sheets(Sheets.Count).Range("a1").PasteSpecial Paste:=xlPasteAll
    
67. 
    
68. wb.Sheets(Sheets.Count).[a1].PasteSpecial Paste:=xlPasteColumnWidths
    
69. 
    
70. wb.Sheets(Sheets.Count).[a2].Resize(c, 8) = crr
    
71. 
    
72. c = 0
    
73. Erase crr
    
74. 
    
75. If Left(arr(j + 1, 8), Len(arr(j + 1, 8)) - 2) <> arrcm(i) Then GoTo 100
    
76. 
    
77. Else
    
78. 
    
79. If Left(arr(j, 8), Len(arr(j, 8)) - 2) = arrcm(i) Then
    
80. 
    
81. 
    
82. c = c + 1
    
83. For k = 1 To 8
    
84. crr(c, k) = arr(j, k)
    
85. Next
    
86. 
    
87. 
    
88. End If
    
89. End If
    
90. 
    
91. If j = UBound(arr) Then
    
92. wb.Close True
    
93. Else
    
94. GoTo 50
    
95. End If
    
96. 100:
    
97. wb.Close True
    
98. Next
    
99. End Sub
    
100. 
     
101. 
     
102. 
     

复制代码

小渔镇.rar (247.67 KB, 下载次数: 72)

2012-5-4 22:27 上传

点击文件名下载附件

小雨饰品

运行错误1004，不知是怎么回事？谢谢

桀骜孤星

你的是03还是10，我在10下正常运行，未在03下测试

特大暴风雨

桀骜孤星 发表于 2012-5-4 22:27
终于搞定了，运行时间有点长

谢谢你！我的版本是EXCEL2003，我试一下。