把一份表格拆分成多分工作表的，改怎么做啊

燕归花谢

我想要达到以下条件，这个程序改怎么编辑啊？
1、从第一行到第2695行，里面有很多2行的空白行，把第一行标题和第二行表头全部复制到所有2行的空白行中。
2、我想以“人员姓名”为切分的办法，将这个大表按人员姓名分成很多小的工作表，工作表名称是“陈从秀”、“范德骏”等姓名。3、范德骏、陈从秀的表最好也要有标题和表头
4、现有的工作表sheet1不做更改。其他的小工作表最好能放在

opiona

1. '*********************************
   
2. '*******  北极狐工作室出品  ******
   
3. '*******  QQ：14885553      ******
   
4. '*********************************
   
5. 
   
6. Sub opiona()
   
7. Application.ScreenUpdating = False '//关闭屏幕刷新
   
8. Application.DisplayAlerts = False '//关闭系统提示
   
9. 
   
10. t = Timer   '//开始时间
    
11. Set sh1 = Sheets("Sheet1")
    
12. For Each sh In ThisWorkbook.Sheets
    
13.     If sh.Name <> sh1.Name Then sh.Delete
    
14. Next sh
    
15. Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
    
16. StrSQL = "SELECT DISTINCT 人员姓名 FROM [" & sh1.Name & "$A2:M65536] where len(人员姓名)>0"
    
17. 
    
18. 
    
19. CRR = GET_SQLCoon(StrSQL, Str_coon, False)
    
20. For I = 0 To UBound(CRR, 1)
    
21.     ThisWorkbook.Worksheets.Add(AFTER:=Worksheets(Worksheets.Count)).Name = CRR(I, 0) '//建立新表
    
22.     Set NEWSH = Sheets(CRR(I, 0))
    
23.     StrSQL1 = "SELECT * FROM [" & sh1.Name & "$A2:M65536] where 人员姓名='" & CRR(I, 0) & "'"
    
24.     StrSQL1 = StrSQL1 & " ORDER BY 日报单号,派工单号,订单号"
    
25.     ARR = GET_SQLCoon(StrSQL1, Str_coon, True)
    
26.     NEWSH.Range("A1").Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR
    
27. Next I
    
28. 
    
29. Application.ScreenUpdating = True '//恢复屏幕刷新
    
30. Application.DisplayAlerts = True '//恢复系统提示
    
31. MsgBox "用时：" & Format(Timer - t, "#0.0000") & " 秒", , "温馨提示!!"  '//提示所用时间
    
32. End Sub
    
33. 
    
34. 
    
35. '*****************************************************************************************
    
36. '函数名：    GET_SQLCoon
    
37. '函数功能：  获得指定SQL的查询结果，自定义连接字符串，可以连接各种数据库
    
38. '返回值：    返回一个二维数组
    
39. '参数1：     StrSQL   字符类型   SQL查询语句
    
40. '参数2：     Str_coon 字符类型   数据库连接语句
    
41. '参数3：     Biaoti   可参数选   是否输出标题，默认带有标题
    
42. '使用方法：  Arr =  GET_SQLCoon(StrSQL,Str_coon,true)
    
43. '            Arr(0,1)  '//数组第一行为标题行，从i=1 开始是数据
    
44. '            Sh2.Range("A2").Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR
    
45. '*****************************************************************************************
    
46. Public Function GET_SQLCoon(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()
    
47. On Error Resume Next    ' 改变错误处理的方式。
    
48. Dim Cn, RS
    
49.    Err.Clear
    
50.    Set Cn = CreateObject("Adodb.Connection") '//新建一个ADO连接
    
51.    Set RS = CreateObject("adodb.recordset")
    
52.        Cn.Open Str_coon
    
53.        RS.Open StrSQL, Cn, 1, 3
    
54. '       If RS.RecordCount > 0 Then '//如果找到数据
    
55.             If Biaoti = True Then
    
56.                  ReDim ARR(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
    
57.                      For A = 0 To RS.Fields.Count - 1  '//导入标题
    
58.                         ARR(0, A) = RS.Fields(A).Name
    
59.                      Next
    
60.                  For I = 0 To RS.RecordCount - 1  '//导入数据
    
61.                      For A = 0 To RS.Fields.Count - 1
    
62.                          ARR(I + 1, A) = RS.Fields(A).Value
    
63.                      Next A
    
64.                      RS.MoveNext
    
65.                  Next
    
66.             Else
    
67.                  ReDim ARR(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
    
68.                  For I = 0 To RS.RecordCount - 1  '//导入数据
    
69.                      For A = 0 To RS.Fields.Count - 1
    
70.                          ARR(I, A) = RS.Fields(A).Value
    
71.                      Next A
    
72.                      RS.MoveNext
    
73.                  Next
    
74.             End If
    
75. '        Else '//如果没有找到数据
    
76. '            ReDim Arr(1, 1)
    
77. '            Arr(0, 0) = ""
    
78. '        End If
    
79. 
    
80.   GET_SQLCoon = ARR
    
81.   Cn.Close  '//关闭ADO连接
    
82.   Set RS = Nothing
    
83.   Set Cn = Nothing  '//释放内存
    
84. End Function
    
85. 
    
86. '*****************************************************************************************
    
87. 
    
88. 
    

复制代码

opiona

日报05-28至06-25.2.rar (251.93 KB, 下载次数: 23)

2013-7-2 13:45 上传

点击文件名下载附件

pwg80

试试这个东东

LMY123

ADO拆分工作表