ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
楼主: zhaogang1960

[Excel 程序开发] 【84期】特殊拆分工作表—拆分工作表数据到工作簿或Access数据库

  [复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-12-22 13:37 | 显示全部楼层
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-12-22 11:14 | 显示全部楼层
小结:


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

本题目是一个综合应用题,可以用数组+字典+排序等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法”

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 6财富 +70 鲜花 +14 技术 +2 收起 理由
cxh2010 + 2 太强大了
jxnu + 2 多谢老师
wpxxsyzx + 5 跟着赵老师的总结又学到好东西!
AVEL + 20 学习SQL,总结经验
xmyjk + 5 学习了,赵老师总结得真好。

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-12-10 17:51 | 显示全部楼层
本帖最后由 hzhb14796 于 2011-12-12 09:57 编辑

做了一个,不知对不??
老师在看看,更改了一下

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +30 技术 +1 收起 理由
zhaogang1960 + 30 + 1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-12-22 11:08 | 显示全部楼层
截至日期已到,谢谢各位参与答题,已测试各位代码,现将各位得分情况公布如下:

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

TA的精华主题

TA的得分主题

发表于 2011-12-13 17:38 | 显示全部楼层
  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. Application.ScreenUpdating = False

  9. wb = Application.GetOpenFilename(fileFilter:="Excel Files (*.xls), *.xls", Title:="Import File")
  10. If wb = 0 Then Exit Sub
  11. Workbooks.Open Filename:=wb, ReadOnly:=True
  12. Set bk1 = ActiveWorkbook

  13. nPath = ThisWorkbook.Path
  14. x = Dir(nPath & "\Record.xls")
  15. If x = "" Then
  16.     Set bk2 = Workbooks.Add
  17.     bk2.SaveAs (nPath & "\Record.xls")
  18. Else
  19.     Set bk2 = Workbooks.Open(nPath & "\Record.xls")
  20. End If

  21. Set dic = CreateObject("Scripting.Dictionary")

  22. With bk1.Sheets(1)
  23.     Lastline = .[A65536].End(xlUp).Row
  24.     For i = 2 To Lastline
  25.         If Not dic.exists(.Cells(i, 3).Value) Then
  26.             dic.Add .Cells(i, 3).Value, ""
  27.             
  28.             For Each ws In bk2.Worksheets
  29.                 If ws.Name = .Cells(i, 3).Value Then
  30.                     nCheck = True
  31.                     Exit For
  32.                 End If
  33.             Next ws
  34.             
  35.             If Not nCheck Then
  36.                 Set ws = bk2.Worksheets.Add(after:=Sheets(Sheets.Count))
  37.                 With ws
  38.                     .Name = bk1.Sheets(1).Cells(i, 3).Value
  39.                     .Cells.Font.Size = 10
  40.                     .Columns(1).NumberFormatLocal = "dd/mm/yy"
  41.                     .Cells(1, 1).Resize(1, 8) = bk1.Sheets(1).Cells(1, 1).Resize(1, 8).Value
  42.                     .Columns(3).NumberFormatLocal = "@"
  43.                 End With
  44.             End If
  45.         End If
  46.     Next i
  47.     Set dic = Nothing
  48.    
  49.     Set dic2 = CreateObject("Scripting.Dictionary")
  50.     For i = Lastline To 2 Step -1
  51.         nCheck = False
  52.         If Not dic2.exists(.Cells(i, 2) & .Cells(i, 3)) Then
  53.             dic2.Add .Cells(i, 2) & .Cells(i, 3), ""
  54.             x = .Cells(i, 1).Resize(1, 8)
  55.             For n = 1 To 8
  56.                 arr(n - 1) = x(1, n)
  57.             Next n
  58.             nStr = Join(arr, "#")
  59.             
  60.             Lastline = bk2.Sheets(.Cells(i, 3).Value).[A65536].End(xlUp).Row
  61.             For r = 2 To Lastline
  62.                 x = bk2.Sheets(.Cells(i, 3).Value).Cells(r, 1).Resize(1, 8)
  63.                 For n = 1 To 8
  64.                     arr2(n - 1) = x(1, n)
  65.                 Next n
  66.                 nStr2 = Join(arr2, "#")
  67.                 If nStr = nStr2 Then
  68.                     nCheck = True
  69.                     Exit For
  70.                 End If
  71.             Next r
  72.             
  73.             If Not nCheck Then bk2.Sheets(.Cells(i, 3).Value).Cells(Lastline + 1, 1).Resize(1, 8) = arr
  74.         End If
  75.     Next i
  76.     Set dic2 = Nothing
  77.    
  78.     For Each ws In bk2.Worksheets
  79.         Set rng = ws.UsedRange
  80.         If IsEmpty(rng) Then
  81.             Application.DisplayAlerts = False
  82.             ws.Delete
  83.             Application.DisplayAlerts = True
  84.         Else
  85.             ws.Columns("A:H").Sort Key1:=ws.Cells(2, 1), Order1:=xlAscending, Header:=xlYes
  86.         End If
  87.     Next ws
  88. End With

  89. bk2.Save
  90. bk1.Close

  91. Application.ScreenUpdating = True

  92. ThisWorkbook.Close

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +50 技术 +2 收起 理由
zhaogang1960 + 50 + 2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-12-20 14:41 | 显示全部楼层
感觉代码笨笨的。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +30 技术 +1 收起 理由
zhaogang1960 + 30 + 1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-12-20 20:16 | 显示全部楼层
  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. Sub ToAccess()
  39.     Dim Sql$, Sql1$, FilesPath$, FielsName, arr, i, j
  40.     Dim Cnn As Object, Cat As Object
  41.     FilesPath = ThisWorkbook.Path & Application.PathSeparator
  42.     Set Cnn = CreateObject("Adodb.Connection")
  43.     Set Cat = CreateObject("ADOX.Catalog")
  44.     FielsName = [{"数据源1.xls","记录.xls","Access记录.mdb";"数据源2.xls","记录2.xls","Access记录2.mdb"}]
  45.     For j = 1 To UBound(FielsName)
  46.         Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0';Data Source=" & FilesPath & FielsName(j, 1)
  47.             arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Cnn.Execute("Select Distinct 商品编号 from [Sheet1$]").GetRows))
  48.             If Dir(FilesPath & FielsName(j, 3)) <> "" Then
  49.                 MsgBox FilesPath & FielsName(j, 3) & "已存在,请删除后再测试本程序"
  50.                 Exit Sub
  51.             Else
  52.                 Cat.CREATE "Provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & FilesPath & FielsName(j, 3)
  53.             End If
  54.             For i = 1 To UBound(arr)
  55.                  On Error GoTo Errhandle
  56.                 '为符合条件的数据加上序号,1为起始数
  57.                 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) & "' "
  58.                 '为符合条件的数据加上错位序号,2为起始数
  59.                 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) & "' "
  60.                 '利用错位序号,得出要剔除的日期
  61.                 Sql = "Select b.日期 from (" & Sql & ") as a Left Join (" & Sql1 & ") as b on a.排名=b.排名 and a.送货单位=b.送货单位"
  62.                 '去除空值
  63.                 Sql = "Select * from (" & Sql & ") Where 日期 is not null "
  64.                 '得出最终结果
  65.                 Sql = "Select a.* from [Sheet1$] as a Left Join (" & Sql & ") as b on a.日期=b.日期  Where b.日期 is null and 商品编号='" & arr(i) & "' "
  66.                 '把最终结果写入相应文件
  67.                 Sql = "Select *  into [;Database=" & FilesPath & FielsName(j, 3) & "]." & arr(i) & " FROM (" & Sql & ")"
  68.                 '执行
  69.                 Cnn.Execute (Sql)
  70.             Next i
  71.         Cnn.Close
  72.     Next j
  73.     Set Cnn = Nothing: Set Cat = Nothing
  74.     Exit Sub
  75. Errhandle:
  76. MsgBox Err.Description
  77. End Sub

复制代码

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


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +20 收起 理由
zhaogang1960 + 20 谢谢支持

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-12-20 21:48 | 显示全部楼层
本帖最后由 xmyjk 于 2011-12-21 16:54 编辑

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

ACCESS的:

  1. Option Explicit
  2. Sub tacc()
  3.     Dim arr, i&, sjy, p%, flag As Boolean, SQL1$, SQL2$, brr, j%

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


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?免费注册

x

评分

参与人数 1财富 +50 技术 +3 收起 理由
zhaogang1960 + 50 + 3

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-12-22 16:34 | 显示全部楼层
赵老师辛苦了。
没有考虑数据源可能存在字段为空的情况,痛失2分,呵呵。。。。

TA的精华主题

TA的得分主题

发表于 2011-12-22 16:39 | 显示全部楼层
本帖最后由 onthetrip2008 于 2011-12-22 16:41 编辑
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高手哦,大意失荆州,呵呵。。。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-3-20 06:06 , Processed in 0.095887 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表