| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 753 人关注过本帖
标题:ado 读取exce后修改另存l
只看楼主 加入收藏
xxyyx82
Rank: 1
等 级:新手上路
帖 子:22
专家分:3
注 册:2015-7-16
结帖率:50%
收藏
 问题点数:0 回复次数:5 
ado 读取exce后修改另存l
程序代码:
Private Sub Command1_Click()
Set xlapp = CreateObject("Excel.Application")
Set xlBook = xlapp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
Dim con As Object
Dim rs As Object
Set con = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Keystr = "%" & "AA" & "%"
con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source = " & App.Path & "\a.xls;Extended Properties='Excel 8.0;HDR=Yes'"
con.Open
Sql = "select 姓名,综合 from [test$] where 项目 like '" & Keystr & "'"
rs.Open Sql, con, 3, 3
For I = 1 To rs.Fields.Count
    xlSheet.Cells(1, I) = rs.Fields(I - 1).Name

 Next
xlSheet.Cells(2, 1).CopyFromRecordset rs


xlBook.SaveAs ("G:\b.xls")
xlBook.Close
xlapp.Application.Quit
Set xlapp = Nothing
Set xlSheet1 = Nothing
Set xlBook = Nothing
rs.Close
Set rs = Nothing
con.Close
Set con = Nothing
End Sub


读取a.xls,想把a.xls中某一列的数值提取后,放在最后一列. 再另存为b.xls
数据量很大,不知如何通过高效的方法来实现
请各位大神指导..
附件中b.xls为需实现的效果。

Test.rar (3.54 KB)
2015-08-23 21:19
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
程序代码:
Option Explicit

Dim objExl As Excel.Application '声明对象变量

Dim path As String

Const xlsfile = "b3.xls"                '保存为b3.xls

Private Sub Command1_Click()

Cls
Print "开始:"; Now

Const strbt = "姓名,综合,最小,最大"
Dim s() As String           '分解数据用的数组
Dim m As String             '保存着需要保存的数据

s = Split(strbt, ",")       '标题

m = Join(s, vbTab)
m = m & vbCrLf

Print "预处理完成:"; Now

Dim keystr As String, sql As String

'Dim con As New ADODB.Connection            '调试用,需要工程引用
'Dim rs As New ADODB.Recordset

Dim con As Object
Dim rs As Object

Set con = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

'keystr = "%" & "AA" & "%"

keystr = "AA"

con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source = " & path & "a.xls;Extended Properties='Excel 8.0;HDR=Yes'"
con.Open
sql = "select 姓名,综合 from [test$] where 项目 = '" & keystr & "';"
rs.Open sql, con, 3, 3

Print "以数据库方式打开表完成:"; Now

If rs.EOF Then
    '没有数据,不打开Excel ,不处理数据
    MsgBox "没有查到数据,文件未保存!", vbCritical

Else

Do While Not rs.EOF                         '使用DO循环
'For i = 0 To rs.RecordCount - 1
    m = m & rs.Fields("姓名") & vbTab       '前面二个值
    m = m & rs.Fields("综合") & vbTab
    
    If Len(rs.Fields("综合")) > 0 Then
    
        s = Split(rs.Fields("综合"), "-")       '第二值分为二段
        
        If UBound(s) > 0 Then                   '如果有二段数据
            If IsNumeric(s(0)) And IsNumeric(s(1)) Then     '两段都是数字
                If Val(s(0)) > Val(s(1)) Then               '如果大的前面
                    m = m & s(1) & vbTab                    '第一段
                    m = m & s(0) & vbCrLf                   '第二段
                Else
                    m = m & s(0) & vbTab                    '第一段
                    m = m & s(1) & vbCrLf                   '第二段
                End If
            Else
                '只有一个是数字
                If IsNumeric(s(0)) Then             '第一个是数字,放后面
                    m = m & vbTab & s(0) & vbCrLf
                ElseIf IsNumeric(s(1)) Then         '第二个是数字,也放后面
                    m = m & vbTab & s(1) & vbCrLf
                Else                                '否则全部留空
                    m = m & vbTab & vbCrLf
                End If
                
            End If
        Else
            If IsNumeric(s(0)) Then                     '如果只有一段,并且是数字,那放后面
                m = m & vbTab & s(0) & vbCrLf
            Else
                m = m & vbTab & vbCrLf                   '否则两段都放空
            End If
        End If
    Else
        m = m & vbTab & vbCrLf                   '否则两段都放空
    End If
    
    rs.MoveNext                             '下一条记录
'Next
Loop

Print "组合数据完成:"; Now

Set objExl = New Excel.Application          '创建一个新的 Exlce
DoEvents

Set objExl = New Excel.Application '初始化对象变量
objExl.SheetsInNewWorkbook = 1 '将新建的工作薄数量设为1
objExl.Workbooks.Add '增加一个工作薄
objExl.Sheets(objExl.Sheets.Count).Name = "Sheet1" '修改工作薄名称

objExl.Visible = True                       '显示Excel
DoEvents

Print "运行Excel完成:"; Now

objExl.Visible = True                           '显示
objExl.Sheets("sheet1").Select                  '选择
'objExl.Sheets("sheet1").Range("A1:D1") = s      '贴入标题

'按这种处理过的数据,放进去时,需要到剪切板上转一下
Clipboard.Clear
Clipboard.SetText m

objExl.Sheets("sheet1").Range("A1").PasteSpecial        '从第一行第一个格贴进去
'objExl.Sheets("sheet1").Range("A2").PasteSpecial        '从第二行第一个格贴进去
Clipboard.Clear                                         '清掉

Print "写入数据完成:"; Now

If Dir(path & xlsfile) <> "" Then
    Kill path & xlsfile
End If

objExl.ActiveWorkbook.SaveAs path & xlsfile
objExl.ActiveWorkbook.Close

End If


End Sub

Private Sub Form_Load()
path = App.path
If Right(path, 1) <> "\" Then
    path = path & "\"
End If



End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next

objExl.ActiveWorkbook.Saved = True
objExl.Quit

Set objExl = Nothing

End Sub

授人于鱼,不如授人于渔
早已停用QQ了
2015-08-28 21:27
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
运行记录:
开始:2015/8/28 21:29:56
预处理完成:2015/8/28 21:29:56
以数据库方式打开表完成:2015/8/28 21:29:56
组合数据完成:2015/8/28 21:29:57
运行Excel完成:2015/8/28 21:29:59
写入数据完成:2015/8/28 21:29:59


总数据量:10368行,不含标题
生成结果:5184行,不含标题

授人于鱼,不如授人于渔
早已停用QQ了
2015-08-28 21:31
xxyyx82
Rank: 1
等 级:新手上路
帖 子:22
专家分:3
注 册:2015-7-16
收藏
得分:0 
回复 2楼 风吹过b
谢谢版主的帮忙,辛苦了
--------------------------------------------------
ADO读取a.xls创建一个Rs记录集
通过数组来处理Rs
m = Join(s, vbTab)
再把数据粘贴保存至b.xls
Clipboard.SetText m
objExl.Sheets("sheet1").Range("A1").PasteSpecial
---------------------------------------------------
我这样理解思维对么?
2015-08-28 22:53
xxyyx82
Rank: 1
等 级:新手上路
帖 子:22
专家分:3
注 册:2015-7-16
收藏
得分:0 
回复 3楼 风吹过b
数据量很大的时候用数组字典确实很高效
谢谢版主。
2015-08-28 22:54
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
我粘贴进去的数据格式是:

数据1  tab  数据2  tab 数据3 ...  数据N crlf
数据1  tab  数据2  tab 数据3 ...  数据N crlf
数据之前都用 vbtab 分隔,每行之行使用 vbcrlf 分隔,这样放到剪切板上,然后就可以一次粘贴到里面去。

--------------
今天看3楼的代码,发现多写了一个,
Set objExl = New Excel.Application          '创建一个新的 Exlce

Set objExl = New Excel.Application '初始化对象变量

这二行写重了,去掉一行,应该有一行是复制你的代码样的。

授人于鱼,不如授人于渔
早已停用QQ了
2015-08-29 22:15
快速回复:ado 读取exce后修改另存l
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.020690 second(s), 8 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved