【84期】特殊拆分工作表—拆分工作表数据到工作簿或Access数据库

zhaogang1960

panan123_0 发表于 2011-12-22 13:30
常规法 我是有点不妥。加个按日期排序代码就妥当了。其实我做的时候就想到了，哎为这扣了一分。我想答案对就 ...

没有追究重发，是算法违反了“常规法和ADO法不得混用”的规定：
    If Dir(sPath & WbName) = "" Then
      Set wb = Workbooks.Add
      wb.SaveAs sPath & WbName
      ActiveWorkbook.Close
    End If

zhaogang1960

小结：


首先感谢冻版主采用此题目，感谢所有参与答题的会员

本题目是一个综合应用题，可以用数组+字典+排序等VBA常规法、也可以用ADO法，解题思路基本相同。
一、常规法
可以用多种方法实现，附件中给出3种（详见附件中的模块2）：
1、字典加数组；
2、字典加数组（字典嵌套）；
3、字典复制区域（字典嵌套，可以复制数据源单元格格式）。
二、ADO法
ADO法可以分为拆分到工作簿（详见模块1）和拆分到Access数据库（详见模块3）两种，两者稍微不同的是：如果工作簿不存在，不能新建一个没有工作表的“空”工作簿，而是新建一个工作表的同时新建工作簿，Access数据库不存在时可以新建一个空数据库。
下面以拆分到工作簿为例讲一下思路：
1、连接数据源
2、按照以“送货单位”和“商品编号”为关键字，如果有重复，按照“日期”字段只取最新的一个纪录要求创建一个查询：

SQL1 = "select  a.* from [Sheet1$] a inner join (select 送货单位,商品编号,max(日期) as 最新日期 from [Sheet1$] group by 送货单位,商品编号) b on a.送货单位=b.送货单位 and a.商品编号=b.商品编号 and a.日期=b.最新日期"

3、创建一个不重复“商品编号”查询：SQL = "select distinct 商品编号 from [Sheet1$]"
4、判断“记录”工作簿是否存在，如果不存在则：新建一个名为第一个“商品编号”的工作表的同时新建工作簿：

cnn.Execute "select * into [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "] from (" & SQL1 & ") where 商品编号='" & rs.Fields(0) & "'"

5、利用ADOX取得“记录”工作簿的工作表名，并添加到字典d，以用于判断每个“商品编号”所在的工作表是否存在
6、逐个“商品编号”判断该“商品编号”工作表是否存在，如果不存在就插入一个该“商品编号”工作表：

cnn.Execute "select * into [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "] from (" & SQL1 & ") where 商品编号='" & rs.Fields(0) & "'"

如果已经存在，将“商品编号”同名的工作表中不存在的记录追加到工作表中：

SQL = "select a.* from (select * from (" & SQL1 & ") where 商品编号='" & rs.Fields(0) & "') a left join [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "$] b on " & a & "=" & b & " where " & b & " is null"
cnn.Execute "insert into [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "$] select * from (" & SQL & ")"

代码如下：
'引用Microsoft Scripting Runtime
'引用Microsoft AD0 Ext 2.8 for DDL and Security
'引用Microsoft ActiveX Data Objects 2.x Library
Sub ADO法()
    Dim cnn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim Cat  As New ADOX.Catalog, tb1 As Table
    Dim d As New Dictionary
    Dim MyFile, arr, i%, s$, SQL$, SQL1$, wn$, a$, b$
    ChDrive Split(ThisWorkbook.Path, ":")(0)
    ChDir ThisWorkbook.Path
    MyFile = Application.GetOpenFilename(fileFilter:="Microsoft Excel Files (*.xls),*.xls", Title:="选择数据源")
    If TypeName(MyFile) = "Boolean" Then Exit Sub
    arr = Array("日期", "送货单位", "商品编号", "商品名称", "单位", "单价", "数量", "金额")
    a = "a." & Join(arr, "&a.")
    b = "b." & Join(arr, "&b.")
    wn = ThisWorkbook.Path & "\记录.xls"
    cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & MyFile '连接数据库
    SQL1 = "select  a.* from [Sheet1$] a inner join (select 送货单位,商品编号,max(日期) as 最新日期 from [Sheet1$] group by 送货单位,商品编号) b on a.送货单位=b.送货单位 and a.商品编号=b.商品编号 and a.日期=b.最新日期"
'    上一句：以“送货单位”和“商品编号”为关键字，如果有重复，按照“日期”字段只取最新的一个纪录
    SQL = "select distinct 商品编号 from [Sheet1$]" '取不重复“商品编号”
    rs.Open SQL, cnn, 1, 3
    If Dir(wn) <> "" Then '如果“纪录”工作簿已经存在
        Cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=No';Data Source=" & wn '连接工作簿以利用ADOX取得工作表名
        For Each tb1 In Cat.Tables
            If tb1.Type = "TABLE" Then
                s = Replace(tb1.Name, "'", "") '表名含有数字时有多余的单引号
                If Right(s, 1) = "$" Then d(Replace(s, "$", "")) = "" '如果是工作表名，则添加该工作表为字典键值
            End If
        Next
        Set Cat = Nothing
        Set tb1 = Nothing
    Else '如果“纪录”工作簿不存在，新建“纪录”工作簿和第一个“商品编号”为表名的工作表
        cnn.Execute "select * into [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "] from (" & SQL1 & ") where 商品编号='" & rs.Fields(0) & "'"
        d("" & rs.Fields(0)) = "" '添加该工作表名到字典键值
    End If
    For i = 1 To rs.RecordCount '逐个“商品编号”
        If Not d.Exists("" & rs.Fields(0)) Then '如果该“商品编号”工作表不存在
            cnn.Execute "select * into [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "] from (" & SQL1 & ") where 商品编号='" & rs.Fields(0) & "'" '插入该“商品编号”工作表
        Else '如果该“商品编号”工作表已经存在
            SQL = "select a.* from (select * from (" & SQL1 & ") where 商品编号='" & rs.Fields(0) & "') a left join [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "$] b on " & a & "=" & b & " where " & b & " is null"
            '该工作表中不存在的新纪录
            cnn.Execute "insert into [Excel 8.0;Database=" & wn & "].[" & rs.Fields(0) & "$] select * from (" & SQL & ")" '插入新纪录
        End If
        rs.MoveNext '下一条记录
    Next
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    MsgBox "ok"
End Sub

三、关于“商品编号”同名的工作表中不存在的记录SQL语句的说明：
不存在可以用not in语句，SQL语句执行 where not in(.....................) 子句判断时 效率极低，数据较大时会出现假死机现象，故这里使用联合语句+where is null 代替。
大家可以先看看ldy版主的小结：
[42期]ado 添加不重复姓名
http://club.excelhome.net/thread-375561-1-1.html
（也可以使用Access的“查找不匹配项查询向导”创建两个数据表的不匹配项，查看得到的SQL语句）
"select a.姓名,a.电话 from " & Tb2 & " as a left outer join " & Tb1 & " as b on a.姓名= b.姓名 where b.姓名 is null"
本题目与上面不同的是，要求比较所有字段来判断在“记录”工作簿中是否存在，即每个记录只要有一个字段不同就不算“记录”工作簿中存在。如果数据源每个字段都没有空格(null)，可以用下面SQL语句表示：
"select a.* from " & Tb2 & " as a left outer join " & Tb1 & " as b on a.字段1=b.字段1 and …and a.字段n=b.字段n… where b.字段1 is null and……and b.字段n is null”
见附件（模块3）“Access法”
如果不能保证数据源每个字段没有空格，则需要把所有字段用&连接起来(相当于一个新字段)比较：
"select a.* from " & Tb2 & " as a left outer join " & Tb1 & " as b on a.字段1&a.字段2&……&a.字段n=b.字段1&b.字段2……&b.字段n  where b.字段1&b.字段2……&b.字段n  is null”
（请注意：用&连接起来比较，效率会大大降低）
见附件（模块1）“ADO法”

hzhb14796

做了一个，不知对不？？
老师在看看，更改了一下

zhaogang1960

截至日期已到，谢谢各位参与答题，已测试各位代码，现将各位得分情况公布如下：

kerryzz

1. Private Sub CommandButton1_Click()
   
2. Dim bk1 As Workbook
   
3. Dim bk2 As Workbook
   
4. Dim ws As Worksheet
   
5. Dim nCheck As Boolean
   
6. Dim arr(8)
   
7. Dim arr2(8)
   
8. 
   
9. Application.ScreenUpdating = False
   
10. 
    
11. wb = Application.GetOpenFilename(fileFilter:="Excel Files (*.xls), *.xls", Title:="Import File")
    
12. If wb = 0 Then Exit Sub
    
13. Workbooks.Open Filename:=wb, ReadOnly:=True
    
14. Set bk1 = ActiveWorkbook
    
15. 
    
16. nPath = ThisWorkbook.Path
    
17. x = Dir(nPath & "\Record.xls")
    
18. If x = "" Then
    
19.     Set bk2 = Workbooks.Add
    
20.     bk2.SaveAs (nPath & "\Record.xls")
    
21. Else
    
22.     Set bk2 = Workbooks.Open(nPath & "\Record.xls")
    
23. End If
    
24. 
    
25. Set dic = CreateObject("Scripting.Dictionary")
    
26. 
    
27. With bk1.Sheets(1)
    
28.     Lastline = .[A65536].End(xlUp).Row
    
29.     For i = 2 To Lastline
    
30.         If Not dic.exists(.Cells(i, 3).Value) Then
    
31.             dic.Add .Cells(i, 3).Value, ""
    
32.             
    
33.             For Each ws In bk2.Worksheets
    
34.                 If ws.Name = .Cells(i, 3).Value Then
    
35.                     nCheck = True
    
36.                     Exit For
    
37.                 End If
    
38.             Next ws
    
39.             
    
40.             If Not nCheck Then
    
41.                 Set ws = bk2.Worksheets.Add(after:=Sheets(Sheets.Count))
    
42.                 With ws
    
43.                     .Name = bk1.Sheets(1).Cells(i, 3).Value
    
44.                     .Cells.Font.Size = 10
    
45.                     .Columns(1).NumberFormatLocal = "dd/mm/yy"
    
46.                     .Cells(1, 1).Resize(1, 8) = bk1.Sheets(1).Cells(1, 1).Resize(1, 8).Value
    
47.                     .Columns(3).NumberFormatLocal = "@"
    
48.                 End With
    
49.             End If
    
50.         End If
    
51.     Next i
    
52.     Set dic = Nothing
    
53.    
    
54.     Set dic2 = CreateObject("Scripting.Dictionary")
    
55.     For i = Lastline To 2 Step -1
    
56.         nCheck = False
    
57.         If Not dic2.exists(.Cells(i, 2) & .Cells(i, 3)) Then
    
58.             dic2.Add .Cells(i, 2) & .Cells(i, 3), ""
    
59.             x = .Cells(i, 1).Resize(1, 8)
    
60.             For n = 1 To 8
    
61.                 arr(n - 1) = x(1, n)
    
62.             Next n
    
63.             nStr = Join(arr, "#")
    
64.             
    
65.             Lastline = bk2.Sheets(.Cells(i, 3).Value).[A65536].End(xlUp).Row
    
66.             For r = 2 To Lastline
    
67.                 x = bk2.Sheets(.Cells(i, 3).Value).Cells(r, 1).Resize(1, 8)
    
68.                 For n = 1 To 8
    
69.                     arr2(n - 1) = x(1, n)
    
70.                 Next n
    
71.                 nStr2 = Join(arr2, "#")
    
72.                 If nStr = nStr2 Then
    
73.                     nCheck = True
    
74.                     Exit For
    
75.                 End If
    
76.             Next r
    
77.             
    
78.             If Not nCheck Then bk2.Sheets(.Cells(i, 3).Value).Cells(Lastline + 1, 1).Resize(1, 8) = arr
    
79.         End If
    
80.     Next i
    
81.     Set dic2 = Nothing
    
82.    
    
83.     For Each ws In bk2.Worksheets
    
84.         Set rng = ws.UsedRange
    
85.         If IsEmpty(rng) Then
    
86.             Application.DisplayAlerts = False
    
87.             ws.Delete
    
88.             Application.DisplayAlerts = True
    
89.         Else
    
90.             ws.Columns("A:H").Sort Key1:=ws.Cells(2, 1), Order1:=xlAscending, Header:=xlYes
    
91.         End If
    
92.     Next ws
    
93. End With
    
94. 
    
95. bk2.Save
    
96. bk1.Close
    
97. 
    
98. Application.ScreenUpdating = True
    
99. 
    
100. ThisWorkbook.Close
     
101. 
     
102. End Sub

复制代码

補充一下, 我的系統不能正常顯示簡體字,
只好把題目要求的儲存檔案為"紀錄.xls" 改為"Record.xls",
請見諒!

岁寒三友

感觉代码笨笨的。

Simon_Zhu

1. Sub ToExcel()
   
2.     Dim Sql$, Sql1$, FilesPath$, FielsName, arr, i, j
   
3.     Dim Cnn As Object
   
4.     FilesPath = ThisWorkbook.Path & Application.PathSeparator
   
5.     Set Cnn = CreateObject("Adodb.Connection")
   
6.     FielsName = [{"数据源1.xls","记录.xls","Access记录.mdb";"数据源2.xls","记录2.xls","Access记录2.mdb"}]
   
7.     For j = 1 To UBound(FielsName)
   
8.         Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0';Data Source=" & FilesPath & FielsName(j, 1)
   
9.             arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Cnn.Execute("Select Distinct 商品编号 from [Sheet1$]").GetRows))
   
10.             If Dir(FilesPath & FielsName(j, 2)) <> "" Then
    
11.                 MsgBox FilesPath & FielsName(j, 2) & "已存在，请删除后再测试本程序"
    
12.                 Exit Sub
    
13.             End If
    
14.             For i = 1 To UBound(arr)
    
15.                 On Error GoTo Errhandle
    
16.                 '为符合条件的数据加上序号，1为起始数
    
17.                 Sql = "Select b.日期,b.送货单位,b.商品编号,(Select count(1) from [Sheet1$]as a Where a.商品编号=b.商品编号 and a.日期<=b.日期 ) as 排名 from [Sheet1$] as b Where 商品编号='" & arr(i) & "' "
    
18.                 '为符合条件的数据加上错位序号，2为起始数
    
19.                 Sql1 = "Select b.日期,b.送货单位,b.商品编号,(Select count(1)+1 from [Sheet1$]as a Where a.商品编号=b.商品编号 and a.日期<=b.日期 ) as 排名 from [Sheet1$] as b Where 商品编号='" & arr(i) & "' "
    
20.                 '利用错位序号,得出要剔除的日期
    
21.                 Sql = "Select b.日期 from (" & Sql & ") as a Left Join (" & Sql1 & ") as b on a.排名=b.排名 and a.送货单位=b.送货单位"
    
22.                 '去除空值
    
23.                 Sql = "Select * from (" & Sql & ") Where 日期 is not null "
    
24.                 '得出最终结果
    
25.                 Sql = "Select a.* from [Sheet1$] as a Left Join (" & Sql & ") as b on a.日期=b.日期  Where b.日期 is null and 商品编号='" & arr(i) & "' "
    
26.                 '把最终结果写入相应文件
    
27.                 Sql = "Select *  into [Excel 8.0;Database=" & FilesPath & FielsName(j, 2) & "].[" & arr(i) & "] FROM (" & Sql & ")"
    
28.                 '执行
    
29.                 Cnn.Execute (Sql)
    
30.             Next i
    
31.         Cnn.Close
    
32.     Next j
    
33.     Set Cnn = Nothing: Set Cat = Nothing
    
34.     Exit Sub
    
35. Errhandle:
    
36. MsgBox Err.Description
    
37. End Sub
    
38. 
    
39. Sub ToAccess()
    
40.     Dim Sql$, Sql1$, FilesPath$, FielsName, arr, i, j
    
41.     Dim Cnn As Object, Cat As Object
    
42.     FilesPath = ThisWorkbook.Path & Application.PathSeparator
    
43.     Set Cnn = CreateObject("Adodb.Connection")
    
44.     Set Cat = CreateObject("ADOX.Catalog")
    
45.     FielsName = [{"数据源1.xls","记录.xls","Access记录.mdb";"数据源2.xls","记录2.xls","Access记录2.mdb"}]
    
46.     For j = 1 To UBound(FielsName)
    
47.         Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0';Data Source=" & FilesPath & FielsName(j, 1)
    
48.             arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Cnn.Execute("Select Distinct 商品编号 from [Sheet1$]").GetRows))
    
49.             If Dir(FilesPath & FielsName(j, 3)) <> "" Then
    
50.                 MsgBox FilesPath & FielsName(j, 3) & "已存在，请删除后再测试本程序"
    
51.                 Exit Sub
    
52.             Else
    
53.                 Cat.CREATE "Provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & FilesPath & FielsName(j, 3)
    
54.             End If
    
55.             For i = 1 To UBound(arr)
    
56.                  On Error GoTo Errhandle
    
57.                 '为符合条件的数据加上序号，1为起始数
    
58.                 Sql = "Select b.日期,b.送货单位,b.商品编号,(Select count(1) from [Sheet1$]as a Where a.商品编号=b.商品编号 and a.日期<=b.日期 ) as 排名 from [Sheet1$] as b Where 商品编号='" & arr(i) & "' "
    
59.                 '为符合条件的数据加上错位序号，2为起始数
    
60.                 Sql1 = "Select b.日期,b.送货单位,b.商品编号,(Select count(1)+1 from [Sheet1$]as a Where a.商品编号=b.商品编号 and a.日期<=b.日期 ) as 排名 from [Sheet1$] as b Where 商品编号='" & arr(i) & "' "
    
61.                 '利用错位序号,得出要剔除的日期
    
62.                 Sql = "Select b.日期 from (" & Sql & ") as a Left Join (" & Sql1 & ") as b on a.排名=b.排名 and a.送货单位=b.送货单位"
    
63.                 '去除空值
    
64.                 Sql = "Select * from (" & Sql & ") Where 日期 is not null "
    
65.                 '得出最终结果
    
66.                 Sql = "Select a.* from [Sheet1$] as a Left Join (" & Sql & ") as b on a.日期=b.日期  Where b.日期 is null and 商品编号='" & arr(i) & "' "
    
67.                 '把最终结果写入相应文件
    
68.                 Sql = "Select *  into [;Database=" & FilesPath & FielsName(j, 3) & "]." & arr(i) & " FROM (" & Sql & ")"
    
69.                 '执行
    
70.                 Cnn.Execute (Sql)
    
71.             Next i
    
72.         Cnn.Close
    
73.     Next j
    
74.     Set Cnn = Nothing: Set Cat = Nothing
    
75.     Exit Sub
    
76. Errhandle:
    
77. MsgBox Err.Description
    
78. End Sub
    
79. 
    

复制代码

搭个末班车，昨天才注意到正式竞赛区84期的这道题目，晚了点，不过幸亏搭上车了，呵呵。

xmyjk

EXCEL拆分的，数据源1和2合起来写。SQL修改完毕，用DMAX处理了。

1. Option Explicit
   
2. Sub tT()
   
3.     Dim arr, i&, sjy, p%, flag As Boolean, SQL1$, SQL2$, brr, j%
   
4. 
   
5.     sjy = Array("数据源1", "数据源2")
   
6.     For p = 0 To 1
   
7.         With CreateObject("adodb.connection")
   
8.             .Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.Path & "" & sjy(p) & ".xls"
   
9.             .CursorLocation = 3
   
10.             arr = .Execute("SELECT DISTINCT 商品编号 FROM [SHEET1$]").getrows
    
11.             brr = .Execute("SELECT DISTINCT 送货单位 FROM [SHEET1$]").getrows
    
12.             For i = 0 To UBound(arr, 2)
    
13.                 On Error Resume Next
    
14.                 .Execute ("select * INTO [" & ThisWorkbook.Path & "\记录.xls].[" & arr(0, i) & "] FROM [sheet1$] where 商品编号=null")
    
15.                 If Err.Number = -2147217900 Then flag = True: Err.Clear
    
16.                 On Error GoTo 0
    
17.                 For j = 0 To UBound(brr, 2)
    
18.                     SQL1 = "select * from [SHEET1$] where 商品编号 = '" & arr(0, i) & "' AND 日期=dmax(""日期"",""SHEET1[        DISCUZ_CODE_0        ]quot;",""送货单位='" & brr(0, j) & "'"")"
    
19.                     If flag = False Then
    
20.                         .Execute ("INSERT INTO [" & ThisWorkbook.Path & "\记录.xls].[" & arr(0, i) & "$] " & SQL1)
    
21.                     Else
    
22.                         SQL2 = "select * from [" & ThisWorkbook.Path & "\记录.xls].[" & arr(0, i) & "$]"
    
23.                         If .Execute(SQL2).RecordCount < .Execute(SQL1 & " union " & SQL2).RecordCount Then
    
24.                             .Execute ("INSERT INTO [" & ThisWorkbook.Path & "\记录.xls].[" & arr(0, i) & "$] " & SQL1)
    
25.                         End If
    
26.                     End If
    
27.                     SQL1 = "": SQL2 = ""
    
28.                 Next
    
29.                 flag = False
    
30.             Next
    
31.             .Close
    
32.         End With
    
33.     Next
    
34.     Erase arr, sjy, brr
    
35. End Sub
    

复制代码

ACCESS的：

1. Option Explicit
   
2. Sub tacc()
   
3.     Dim arr, i&, sjy, p%, flag As Boolean, SQL1$, SQL2$, brr, j%
   
4. 
   
5.     If Dir(ThisWorkbook.Path & "\记录.mdb") = "" Then
   
6.         With CreateObject("ADOX.Catalog")
   
7.             .Create "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & ThisWorkbook.Path & "\记录.mdb"
   
8.         End With
   
9.     End If
   
10.     sjy = Array("数据源1", "数据源2")
    
11.     For p = 0 To 1
    
12.         With CreateObject("adodb.connection")
    
13.             .Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & ThisWorkbook.Path & "\记录.mdb"
    
14.             .CursorLocation = 3
    
15.             arr = .Execute("SELECT DISTINCT 商品编号 FROM [Excel 8.0;Database=" & ThisWorkbook.Path & "" & sjy(p) & ".xls].[SHEET1$]").getrows
    
16.             brr = .Execute("SELECT DISTINCT 送货单位 FROM [Excel 8.0;Database=" & ThisWorkbook.Path & "" & sjy(p) & ".xls].[SHEET1$]").getrows
    
17.             For i = 0 To UBound(arr, 2)
    
18.                 On Error Resume Next
    
19.                 .Execute ("select * INTO " & arr(0, i) & " FROM [Excel 8.0;Database=" & ThisWorkbook.Path & "" & sjy(p) & ".xls].[sheet1$] where 商品编号=null")
    
20.                 If Err.Number = -2147217900 Then flag = True: Err.Clear
    
21.                 On Error GoTo 0
    
22.                 For j = 0 To UBound(brr, 2)
    
23.                     SQL1 = "select * from [Excel 8.0;Database=" & ThisWorkbook.Path & "" & sjy(p) & ".xls].[SHEET1$] where 商品编号 = '" & arr(0, i) & "' AND 日期=dmax(""日期"",""SHEET1[        DISCUZ_CODE_1        ]quot;",""送货单位='" & brr(0, j) & "'"")"
    
24.                     If flag = False Then
    
25.                         .Execute ("INSERT INTO " & arr(0, i) & " " & SQL1)
    
26.                     Else
    
27.                         SQL2 = "select * from " & arr(0, i)
    
28.                         If .Execute(SQL2).RecordCount < .Execute(SQL1 & " union " & SQL2).RecordCount Then
    
29.                             .Execute ("INSERT INTO " & arr(0, i) & " " & SQL1)
    
30.                         End If
    
31.                     End If
    
32.                     SQL1 = "": SQL2 = ""
    
33.                 Next
    
34.                 flag = False
    
35.             Next
    
36.             .Close
    
37.         End With
    
38.     Next
    
39.     Erase arr, sjy, brr
    
40. End Sub
    

复制代码

onthetrip2008

赵老师辛苦了。
没有考虑数据源可能存在字段为空的情况，痛失2分，呵呵。。。。

onthetrip2008

Simon_Zhu 发表于 2011-12-22 14:25
接上当时觉得：哎哟，难点出来了。于是仔细研究数据源2.xls的数据规律，结合赵版的题目要求（以“送货单位” ...

simon_zhu老师,好久没看见你了哈,在这里碰见你了,向你问声好。
我曾得到你的耐心指导：
http://club.excelhome.net/thread-584524-1-1.html
http://club.excelhome.net/thread-588891-1-1.html
你可是SQL高手哦，大意失荆州，呵呵。。。