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考勤计算系统
查看: 7482|回复: 34

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2011-11-25 19:43 | 显示全部楼层 |阅读模式
本帖最后由 冻豆腐 于 2011-12-22 08:15 编辑

1.答题前请先阅读最新规则:正式竞赛区运行规则说明
2.可跟贴直接发答案、并上传答案附件

3.题目说明及答题要求:
本题目为实际应用题,题目如下:
每天都有一份数据(见“数据源1”和“数据源2”工作簿),需要按照“商品编号”字段(由数字组成的字符串)拆分,保存到另一个叫做“纪录”的工作簿"纪录.xls"(或Access数据库"记录.mdb",下同)中的同名工作表(或Access数据表,下同)中。以“送货单位”和“商品编号”为关键字,如果有重复,按照“日期”字段只取最新的一个纪录,判断“纪录”工作簿是否存在,如果不存在就新建一个,判断和“商品编号”字段同名的工作表是否存在,不存在也要新建一个,插入该表中不存在的新纪录(确保该表中的记录不重复)。
方法不限。如果使用ADO法拆分到工作簿或Access数据库,要求只能连接一次且不能连接自身,所有操作过程均不能打开工作簿或Access数据库,即常规法和ADO法不得混用,答案正确且方法符合要求者可得分,同时使用常规法、ADO法拆分到工作簿,ADO法拆分到Access数据库三种方法中的两种或以上者可另行加分。

下面附件中有两个数据源工作簿、要求达到的效果——两个“纪录”工作簿和两个“纪录”数据库,代码要求写在一个新工作簿上面

评分:
1.总分3分。
2.精彩答案另加分。

截至日期:2011-12-21前
改错说明:原《记录(新建时执行数据源1效果)》有误,是新建时执行数据源2的效果,现已纠正为“新建时执行数据源1效果”
记录2(执行数据源2效果)是在记录(新建时执行数据源1效果)的基础上再执行数据源2的效果








该贴已经同步到 zhaogang1960的微博

本帖子中包含更多资源

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

x

评分

参与人数 3财富 +50 鲜花 +5 技术 +2 收起 理由
软件爱好者 + 2
oyzhjr + 3 值得肯定,不是屠龙之术。
冻豆腐 + 50 + 2 出题奖励

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-28 10:29 | 显示全部楼层
本帖最后由 gdfcx 于 2011-11-30 11:00 编辑


不知道我理解的对否,请斑竹过目:


本帖子中包含更多资源

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

x

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-28 11:17 | 显示全部楼层
奉上一个较笨的 VBA
希望能大众化一点

本帖子中包含更多资源

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

x

TA的精华主题

TA的得分主题

发表于 2011-11-28 14:39 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2011-11-28 14:41 | 显示全部楼层
Sorry, not attached file before.

本帖子中包含更多资源

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

x

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-29 04:05 | 显示全部楼层
本帖最后由 AVEL 于 2011-11-29 16:54 编辑


还请赵老师多指导。
常规方法,有所修改。

本帖子中包含更多资源

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

x

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-29 09:16 | 显示全部楼层
本帖最后由 陈国华 于 2011-11-29 13:42 编辑

第一次参赛,内心忐忑{:soso_e100:}, 原来只用3个字段是否重复为依据来作判断记录是否重复,现在更正为8个字段,另外"记录.xls"再次打开时变成了隐藏模式,也已更正!

本帖子中包含更多资源

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

x

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-11-29 17:54 | 显示全部楼层
ADO导至Access

  1. Dim cat, myPath$

  2. Sub InsertValues()
  3.    
  4.     Dim cnn, cnnA, rst, strSqlL$, strSqlM$, strSqlR$
  5.     Dim tblName$, myPathFull$, strCnn$, strSqlc$
  6.    
  7.     Set cnn = CreateObject("ADODB.Connection")
  8.     Set cnnA = CreateObject("ADODB.Connection")
  9.     Set rst = CreateObject("ADODB.Recordset")
  10.     myPathFull = ThisWorkbook.Path & "" & "数据源2\数据源2.xls"
  11.     myPath = ThisWorkbook.Path & "" & "Data"
  12.    
  13.     strSqlL = " Select 商品编号 as fNumber,送货单位 as company,first(日期) as fdate,first(商品名称) as fName," & _
  14.             "first(单位) as unit,first(单价) as price,first(数量) as quantity,first(金额) as fmoney From(Select" & _
  15.             " * From[Sheet1$A:H] In '" & myPathFull & "'[Excel 8.0;] Order by 日期,商品编号,送货单位) "
  16.     strSqlR = " Group by 商品编号,送货单位"
  17.    
  18.     cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;" & _
  19.              "Data Source=" & myPathFull
  20.     Set rst = cnn.Execute("Select distinct 商品编号 From[Sheet1$C:C]")
  21.    
  22.     strCnn = "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & myPath
  23.     Call tblBool(strCnn)
  24.     cnnA.Open strCnn & "Data.mdb"
  25.    
  26.     Do Until rst.EOF
  27.    
  28.         tblName = rst(0).Value
  29.         strSqlM = "Where 商品编号='" & tblName & "'"

  30.         If cnnA.openschema(adschematables, Array(Empty, Empty, tblName)).EOF Then
  31.             strSqlc = "Create table " & tblName & " (fNumber text(5),company text(20),fdate datetime," & _
  32.                         "fName text(20),unit text(5),price double,quantity double,fmoney double)"
  33.             cnnA.Execute strSqlc
  34.         End If
  35.         
  36.         cnnA.Execute "Delete * From " & tblName
  37.         cnnA.Execute "Insert into " & tblName & strSqlL & strSqlM & strSqlR
  38.         rst.MoveNext
  39.     Loop
  40.    
  41.     cnn.Close: cnnA.Close
  42.     Set rst = Nothing: Set cnn = Nothing: Set cnnA = Nothing
  43.    
  44. End Sub

  45. Sub tblBool(strCnn As String)
  46.    
  47.     Dim myFile$
  48.    
  49.     Set cat = CreateObject("ADOX.Catalog")
  50.     myFile = Dir(myPath & "*.mdb")
  51.    
  52.     While myFile <> ""
  53.         If myFile = "Data.mdb" Then
  54.             Exit Sub
  55.         End If
  56.     Wend
  57.     cat.Create strCnn & "Data.mdb"
  58.     Set cat = Nothing
  59.    
  60. End Sub

复制代码

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2011-12-1 12:11 | 显示全部楼层



ADO导至Excel

[code=vb]

Sub InsertValues()
   
    Dim cnn, rst, rst1, strSqlL$, strSqlM$, strSqlR$, bool As Boolean
    Dim tblName$, myPathFull$, strSqlc$, myPath$, t, i%
   
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    Set rst1 = CreateObject("ADODB.Recordset")
    myPathFull = ThisWorkbook.Path & "\" & "数据源2\数据源2.xls"
    myPath = ThisWorkbook.Path & "\" & "Data\Data.xls"
    Application.DisplayAlerts = False
   
    strSqlL = "Select 商品编号 as fNumber,送货单位 as company,first(日期) as fdate,first(商品名称) as fName," & _
            "first(单位) as unit,first(单价) as price,first(数量) as quantity,first(金额) as fmoney From(Select" & _
            " * From[Sheet1$A:H]  Order by 日期,商品编号,送货单位) "
    strSqlR = " Group by 商品编号,送货单位"
   
    On Error Resume Next
    Workbooks.Open Filename:=myPath
    If Err.Number <> 0 Then
        Workbooks.Add
        ActiveWorkbook.SaveAs Filename:=myPath
    End If
   
    cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;" & _
             "Data Source=" & myPathFull
    Set rst = cnn.Execute("Select distinct 商品编号 From[Sheet1$C:C]")
   
    With Workbooks("Data.xls")
        Do Until rst.EOF
            tblName = rst(0).Value
            strSqlM = "Where 商品编号='" & tblName & "'"
            Set rst1 = cnn.Execute(strSqlL & strSqlM & strSqlR)
            For Each sht In .Worksheets
                If sht.Name = tblName Then
                    bool = True
                End If
            Next sht
            If Not bool Then .Worksheets.Add: .ActiveSheet.Name = tblName
            .Worksheets(tblName).Range("A2").CopyFromRecordset rst1
            For i = 0 To 7
                .Worksheets(tblName).Cells(1, i + 1) = rst1.Fields(i).Name
            Next i
            rst.MoveNext
        Loop
        .Worksheets("Sheet1").Delete
        .Close True
    End With
   
    Application.DisplayAlerts = True
    cnn.Close
    Set rst = Nothing: Set rst1 = Nothing: Set cnn = Nothing
   
End Sub

[/code]

<======================================================>

以下是我的解题思路,虽然我更喜欢用链接表方式做.呵呵....

Access导入Excel数据

[code=vb]

Option Compare Database
Sub test()
   
    Dim myPathFull$, cnn, rst, tblName$, i%, t%
    Dim strSqlL$, strSqlR$, strSqlM$, arrSql() As String
   
    On Error Resume Next
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset"): i = 0
    myPathFull = Left(CurrentDb.Name, Len(CurrentDb.Name) - 14) & "数据源2\数据源2.xls"
   
    strSqlL = " Select 商品编号 as fNumber,送货单位 as company,first(日期) as fdate,first(商品名称) as fName," & _
            "first(单位) as unit,first(单价) as price,first(数量) as quantity,first(金额) as fmoney From(Select" & _
            " * From[Sheet1$A:H] In '" & myPathFull & "'[Excel 8.0;] Order by 日期,商品编号,送货单位) "
    strSqlR = " Group by 商品编号,送货单位"
   
    cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;" & _
             "Data Source=" & myPathFull
    Set rst = cnn.Execute("Select distinct 商品编号 From[Sheet1$C:C]")
    ReDim arrSql(1)
    While Not rst.EOF
        
        tblName = rst(0).Value
        strSqlM = "Where 商品编号='" & tblName & "'"
        strSqlc = "Create table " & tblName & " (fNumber text(5),company text(20),fdate datetime," & _
                    "fName text(20),unit text(5),price double,quantity double,fmoney double)"
        DoCmd.RunSQL strSqlc
        DoCmd.RunSQL "Delete * From " & tblName
        
        arrSql(i) = "Insert Into " & tblName & strSqlL & strSqlM & strSqlR
        rst.MoveNext: i = i + 1
        ReDim Preserve arrSql(UBound(arrSql) + 1)
        
    Wend
   
    cnn.Close
    Set cnn = Nothing: Set rst = Nothing
   
    For t = 0 To i
        DoCmd.RunSQL arrSql(t)
    Next t
   
End Sub

[/code]

本帖子中包含更多资源

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

x

TA的精华主题

TA的得分主题

发表于 2011-12-1 21:16 | 显示全部楼层
先交个常规法,回头想想其他方法。

本帖子中包含更多资源

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

x

评分

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

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2019-3-21 01:51 , Processed in 1.129940 second(s), 33 queries , Gzip On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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