查看: 1424|回复: 3
如何用vba连接数据库并读出某张表的数据，然后把表的数据导出到excel的ListObje表里面
初级二, 积分 53, 距离下一级还需 197 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
免费注册成为本站会员，享用更多功能，结识更多Office办公高手！
才可以下载或查看，没有帐号？
如题，我想用vba 连接db2，查询其中某张表的数据，并把查询结果导出到excel，以excel 的表格显示数据，使表格有表头，隔行显示不同的颜色。利用MS Query 连接诶数据库并到处数据录制宏时得到的代码是：Sub Macro1()
'
' Macro1 Macro
'
'
& & With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
& && &&&&ODBC;DSN=UID=;MODE=SHARE;DBALIAS=&, Destination:= _
& && &&&Range(&$A$1&)).QueryTable
& && &&&.CommandText = Array( _
& && &&&&SELECT * from t_fact where type='SF')& _
& && &&&)
& && &&&.RowNumbers = False
& && &&&.FillAdjacentFormulas = False
& && &&&.PreserveFormatting = True
& && &&&.RefreshOnFileOpen = False
& && &&&.BackgroundQuery = True
& && &&&.RefreshStyle = xlInsertDeleteCells
& && &&&.SavePassword = False
& && &&&.SaveData = True
& && &&&.AdjustColumnWidth = True
& && &&&.RefreshPeriod = 0
& && &&&.PreserveColumnInfo = True
& && &&&.ListObject.DisplayName = &Table_Query_from_XXXX&
& && &&&.Refresh BackgroundQuery:=False
& & End With
& & ActiveSheet.ListObjects(&Table_Query_from_XXXX&).TableStyle = _
& && &&&&TableStyleMedium2&
End Sub复制代码我另外用vba 连接数据库并读数据的代码如下：Sub Main()
Dim Conn As New ADODB.Connection
Dim RS As New ADODB.Recordset
Dim Cmd As mand
Dim sqlText As String
Dim Row As Long
Dim Findex As Long
Dim Data As Worksheet
Dim X As Long
Dim UID As String
Dim PWD As String
Dim Server As String
Dim strConnect As String
Application.Calculation = xlCalculationManual
UID = &xxxx&
PWD = &xxxx&
Server = &SERVER&
Workbooks(converfilename).Activate
Set Data = ActiveWorkbook.Sheets(2)
Data.Select
Range(&A:F&).ClearContents
strConnect = &Provider=IBMDADB2;Database=Hostname=Protocol=TCPIP;Port=Uid=& & UID & &;Pwd=& & PWD & &;&
Conn.Open strConnect
'&Range('$A$1')).QueryTable&
Cmd.ActiveConnection = Conn
<mandType = adCmdText
sqlText = &SELECT * from t_fact where type='SF'&
<mandText = sqlText
Set RS = Cmd.Execute
Data.Cells(1, X + 1) = RS.Fields(X).Name
Next
Do While Not RS.EOF
Row = Row + 1
For Findex = 0 To RS.Fields.Count - 1
Data.Cells(Row + 1, Findex + 1) = RS.Fields(Findex).Value
Next Findex
RS.MoveNext
Loop
Application.Calculation = xlCalculationAutomatic
Application.Calculate
RS.Close
Conn.Close
Workbooks(converfilename).Activate
End Sub
复制代码但是我用第2中方法读出数据的显示格式不是表格的格式，要怎么做令其以表的格式显示呢？
或着该怎么修改第一种方法呢？我尝试过改，可是因为对方法的参数不了解，老是改不对。
有谁知道怎么做吗？
学office，哪能不关注全网最大的Office类微博（新浪）
中级一, 积分 500, 距离下一级还需 250 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
For Findex = 0 To RS.Fields.Count - 1
Data.Cells(Row + 1, Findex + 1) = RS.Fields(Findex).Value
Next Findex
这不是把数据输入表吗？你说的不是表格式，是什么意思。来个截图？
学office，哪能不关注全网最大的Office类微博（新浪）
初级二, 积分 53, 距离下一级还需 197 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
哦，是我表达不够清楚 现在我知道了，我应该这样说，把读出的所有数据添加到一个新建的ListObjects 中去，如下：
p7.png (2.78 KB, 下载次数: 0)
11:03 上传
想做到这样效果，我在方法2 后面加上如下代码就可以了
Workbooks(converfilename).Sheets(2).Activate
ActiveSheet.ListObjects.Add(xlSrcRange, Data.UsedRange, , xlYes).Name = _
& && &&&&Table_Query_from_**x&
学office，哪能不关注全网最大的Office类微博（新浪）
初级二, 积分 53, 距离下一级还需 197 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
本帖最后由 xiaoxiao029 于
17:09 编辑
通过修改比较后，发现第1种方法的运行速度远远快于第2种方法，特此把第1种的方法粘贴出来，希望对要实现相同功能的朋友有帮助。Const converfilename As String = &xxxx.xlsm&
Sub main()
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long
Dim uid As String
Dim pwd As String
Set ws2 = Workbooks(converfilename).Worksheets(2)
uid = ws2.Range(&G4&)
pwd = ws2.Range(&G5&)
ws2.Range(&G5&) = &&
If uid = && Or pwd = && Then
MsgBox &Please enter the User id and Password first &
Exit Sub
End If
On Error GoTo ErrorHandler
Set ws = Workbooks(converfilename).Worksheets(3)
If ws.ListObjects.Count & 0 Then
ws.ListObjects(1).Delete
End If
With ws.ListObjects.Add(SourceType:=0, Source:= _
& && &&&&ODBC;DSN=UID=& & uid & &;PWD=& & pwd & &;MODE=SHARE;DBALIAS=&, Destination:= _
& && &&&ws.Range(&$A$1&)).QueryTable
& && && &.CommandText = Array(&select * from db2.student WHERE student.status='SF'&)
& && &&&.RowNumbers = False
& && &&&.FillAdjacentFormulas = False
& && &&&.PreserveFormatting = True
& && &&&.RefreshOnFileOpen = False
& && &&&.BackgroundQuery = True
& && &&&.RefreshStyle = xlInsertDeleteCells
& && &&&.SavePassword = False
& && &&&.SaveData = True
& && &&&.AdjustColumnWidth = True
& && &&&.RefreshPeriod = 0
& && &&&.PreserveColumnInfo = True
& && &&&.ListObject.DisplayName = &Table_Query_from_xxxxx&
& && &&&.Refresh BackgroundQuery:=False
& & End With
& & ws.ListObjects(1).TableStyle = _
& && &&&&TableStyleMedium2&
& & Application.DisplayAlerts = False
& & Workbooks(converfilename).Save
& & Application.DisplayAlerts = True
& & ws.Activate
& & Exit Sub
ErrorHandler:
&&MsgBox &something wrong for connecting , Please if User id and Password are all correct &
& &
End Sub复制代码在处理出错的方面，我做的不够好，有兴趣的朋友可以帮忙分享如何完善一下当程序出错时处理。谢谢
学office，哪能不关注全网最大的Office类微博（新浪）
站长推荐 /1
关注 微信号：exceltip_net
回复“教程”二字，即可下载。
Excel技巧网的会员探讨问题仅代表其个人意见，与网站的立场无关。任何违反国家和地方相关法律法规的言论，本站有义务协助政府相关部门追究发言者的责任！
本站中非注明转载文章与案例的版权为作者与Excel技巧网共有。若非原文作者，本站之外任何单位或个人未经允许，不得将其用于商业用途。
若非原文作者，任何形式的非商业性转载必须获得Excel技巧网或作者允许，并注明作者和出处。
会员发表的帖子如涉及版权纠纷，须自行负责。详情请参考注册时的网站服务条款。
本站特聘法律顾问：沈学律师
Excel技巧网
Powered byVBA中的Application.Calculate是怎么用的，在什么情况下需要用这个？_百度知道
VBA中的Application.Calculate是怎么用的，在什么情况下需要用这个？
Offset(0,&#39;
rngTime.Private Sub Worksheet_Change(ByVal Target As Range)
Application:=xlValues
Aone cell to the right of the active cell:ss&quot.EnableEvents = False
rngTThe &quot，为什么这里面要用calculate.EnableEvents = TrueEnd Sub&#39.NumberFormat = &quot:Sub timestamp()
Dim rngTime As Range
Set rngTime = ActiveCell
rngTime.可以帮我看一下这段代码么;event again and cause an endless loop,&#39;EnableEvents&quot, because otherwise.&#39.PasteSpecial Pbut then you have to change it to a valueOption Explicit&#39, 1);enters his name in any cell.Copy
rngTYou can use the =now() funcThe following code on the worksheet object will place&#39;d trigger the Change&#39.CutCopyMode = False
ActiveCell.FormulaR1C1 = &when the the timestamp to the right automatically when the user&#39; lines are necessary.Select
Application,&#39, it&#39;=NOW()&The following code will put the time？还有第二段sub的意义何在;h:mm.SelectEnd Sub&#39, as a value
提问者采纳
他之前 不是在当前单元格输入了 =now() 吗
为了重算这个公式的， 基本没什么用.EnableEvents = False
Target.EnableEvents = TrueEnd Sub这段代码是 工作表
内容改变触发事件.Select
Application， 他触发的事件是调用第一个SUB
， 你删掉试试就知道了，Private Sub Worksheet_Change(ByVal Target As Range)
Application
提问者评价
谢谢啦，这段代码无用的部分还挺多，之前一直不知道为什么写这么多
其他类似问题
vba的相关知识
等待您来回答
下载知道APP
随时随地咨询
出门在外也不愁查看: 16350|回复: 11|
在线时间58 小时经验310 威望0 性别女最后登录注册时间阅读权限20UID155902积分310帖子精华0分享0
EH初级, 积分 310, 距离下一级还需 40 积分
积分排行3941帖子精华0微积分0
sheet1工作表内某个区域有随机函数，能不能设计一个按钮，当按下该按钮时才进行计算，直到再次按下才重新产生新的数据。要求是：在工作簿中所有工作表内按F9时都不会对sheet1工作表进行计算。
(5.3 KB, 下载次数: 50)
12:29 上传
下载次数: 50
如何用VBA关闭屏幕刷新
猜你喜欢看
在线时间57 小时经验2974 威望1 性别男最后登录注册时间阅读权限70UID303817积分3074帖子精华0分享0
EH铁杆, 积分 3074, 距离下一级还需 126 积分
积分排行327帖子精华0微积分0
建议发到VBA版块中去。
在线时间493 小时经验5896 威望12 性别男最后登录注册时间阅读权限95UID178240积分6896帖子精华0分享0
积分排行120帖子精华0微积分0
application.ScreenUpdating=False
在线时间0 小时经验9 威望0 性别男最后登录注册时间阅读权限20UID357381积分59帖子精华0分享0
EH初级, 积分 59, 距离下一级还需 291 积分
积分排行3000+帖子精华0微积分0
很简单首先，在workbook open事件中输入：'把F9键的功能屏蔽掉Application.OnKey "{F9}", ""之后，在sheet里画个按钮，按钮click事件中输入：'重新计算Application.Calculate
在线时间415 小时经验1827 威望0 最后登录注册时间阅读权限70UID127836积分2177帖子精华0分享0
EH铁杆, 积分 2177, 距离下一级还需 1023 积分
积分排行473帖子精华0微积分0
发错地方了
在线时间58 小时经验310 威望0 性别女最后登录注册时间阅读权限20UID155902积分310帖子精华0分享0
EH初级, 积分 310, 距离下一级还需 40 积分
积分排行3941帖子精华0微积分0
不能帮我搞一下么，我很笨的！
在线时间6 小时经验1275 威望0 性别男最后登录注册时间阅读权限50UID171555积分1925帖子精华0分享0
EH高级, 积分 1925, 距离下一级还需 75 积分
积分排行546帖子精华0微积分0
首先设置：工具－选项－重新计算 －手动计算，以避免工作表打开时重新计算。
(7.22 KB, 下载次数: 24)
18:52 上传
下载次数: 24
如何用VBA关闭屏幕刷新
在线时间58 小时经验310 威望0 性别女最后登录注册时间阅读权限20UID155902积分310帖子精华0分享0
EH初级, 积分 310, 距离下一级还需 40 积分
积分排行3941帖子精华0微积分0
以下是引用huiz999在 18:53:24的发言：首先设置：工具－选项－重新计算 －手动计算，以避免工作表打开时重新计算。非常感谢，不过您传的附件里，按下按钮会使所有工作表都进行计算，我想要这个宏只对sheet1起作用！
在线时间6 小时经验1275 威望0 性别男最后登录注册时间阅读权限50UID171555积分1925帖子精华0分享0
EH高级, 积分 1925, 距离下一级还需 75 积分
积分排行546帖子精华0微积分0
Sub 重新计算()Application.ActiveSheet.CalculateEnd Sub
在线时间58 小时经验310 威望0 性别女最后登录注册时间阅读权限20UID155902积分310帖子精华0分享0
EH初级, 积分 310, 距离下一级还需 40 积分
积分排行3941帖子精华0微积分0
以下是引用huiz999在 20:03:11的发言：Sub 重新计算()Application.ActiveSheet.CalculateEnd Sub太感谢了，要的就是这个样子的，请欣赏结果！
(52.53 KB, 下载次数: 138)
22:20 上传
下载次数: 138
[此贴子已经被作者于 22:20:51编辑过]
优秀会员奖章No.1
积分≥4700即可申请
最佳会员奖章No.1
金牌优秀会员
金牌优秀会员奖章No.1
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&