2010年 总版技术专家分年内排行榜第二
2009年 总版技术专家分年内排行榜第三
本帖子已过去太久远了，不再提供回复功能。不打开工作簿提取数据的四种方法
不打开工作簿提取数据的四种方法
来源：& 作者：admin
使用公式取得数据
Sub UsingTheFormula()
&&& Dim Temp As String
&&& Temp = "'" & ThisWorkbook.Path & "\[数据.xlsx]Sheet1'!"
&&& With Sheet1.Range("A1:F22")
&&&&&&& .FormulaR1C1 = "=" & Temp & "RC"
&&&&&&& .Value = .Value
&&& End With
使用GetObject函数
Sub UseGetObject()
&&& Dim Wb As Workbook
&&& Dim Temp As String
&&& Temp = ThisWorkbook.Path & "\数据.xlsx"
&&& Set Wb = GetObject(Temp)
&&& With Wb.Sheets(1).Range("A1").CurrentRegion
&&&&&&& Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
&&& End With
&&& Wb.Close False
&&& Set Wb = Nothing
隐藏Application对象
Sub HideApplication()
&&& Dim MyApp As New Application
&&& Dim Sht As Worksheet
&&& Dim Temp As String
&&& Temp = ThisWorkbook.Path & "\数据.xlsx"
&&& MyApp.Visible = False
&&& Set Sht = MyApp.Workbooks.Open(Temp).Sheets(1)
&&& With Sht.Range("A1").CurrentRegion
&&&&&&& Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
&&& End With
&&& MyApp.Quit
&&& Set MyApp = Nothing
&&& Set Sht = Nothing
使用ExecuteExcel4Macro方法
Sub UsingMacroFunction()
&& &Dim RCount As Long
&&& Dim CCount As Long
&&& Dim Temp As String
&&& Dim Temp1 As String
&&& Dim Temp2 As String
&&& Dim Temp3 As String
&&& Dim r As Long
&&& Dim c As Long
&&& Dim arr() As Variant
&&& Temp = "'" & ThisWorkbook.Path & "\[数据.xlsx]Sheet1'!"
&&& Temp1 = "Counta(" & Temp & Rows(1).Address(, , xlR1C1) & ")"
&&& CCount = Application.ExecuteExcel4Macro(Temp1)
&&& Temp2 = "Counta(" & Temp & Columns("A").Address(, , xlR1C1) & ")"
&&& RCount = Application.ExecuteExcel4Macro(Temp2)
&&& ReDim arr(1 To RCount, 1 To CCount)
&&& For r = 1 To RCount
&&&&&&& For c = 1 To CCount
&&&&&&&&&&& Temp3 = Temp & Cells(r, c).Address(, , xlR1C1)
&&&&&&&&&&& arr(r, c) = Application.ExecuteExcel4Macro(Temp3)
&&&&&&& Next
&&& Range("A1").Resize(RCount, CCount).Value = arr
使用SQL连接
Sub UsingSQL()
&&& Dim Sql As String
&&& Dim j As Integer
&&& Dim r As Integer
&&& Dim Cnn As ADODB.Connection
&&& Dim rs As ADODB.Recordset
&&& With Sheet1
&&&&&&& .Cells.Clear
&&&&&&& Set Cnn = New ADODB.Connection
&&&& &&&With Cnn
&&&&&&&&&&& .Provider = "Microsoft.ACE.OLEDB.12.0"
&&&&&&&&&&& .ConnectionString = "Extended Properties=Excel 12.0;" _
&&&&&&&&&&&&&&& & "Data Source=" & ThisWorkbook.Path & "\数据.xlsx"
&&&&&&&&&&& .Open
&&&&&&& End With
&&&&&&& Set rs = New ADODB.Recordset
&&&&&&& Sql = "Select * From [Sheet1$]"
&&&&&&& rs.Open Sql, Cnn, adOpenKeyset, adLockOptimistic
&&&&&&& For j = 0 To rs.Fields.Count - 1
&&&&&&&&&&& .Cells(1, j + 1) = rs.Fields(j).Name
&&&&&&& Next
&&&&&&& r = .Cells(.Rows.Count, 1).End(xlUp).Row
&&&&&&& .Range("A" & r + 1).CopyFromRecordset rs
&&& End With
&&& rs.Close
&&& Cnn.Close
&&& Set rs = Nothing
&&& Set Cnn = Nothing
相关新闻 & & &
尊重网上道德，遵守中华人民共和国的各项有关法律法规
承担一切因您的行为而直接或间接导致的民事或刑事法律责任
本站管理人员有权保留或删除其管辖留言中的任意内容
本站有权在网站内转载或引用您的评论
参与本评论即表明您已经阅读并接受上述条款
网站简介 - 广告服务 - 网站地图 - 帮助信息 - 联系方式Copyright & 　Powered by君，已阅读到文档的结尾了呢~~
扫扫二维码，随身浏览文档
手机或平板扫扫即可继续访问
利用ExcelVBA读取外部数据技术研究
举报该文档为侵权文档。
举报该文档含有违规或不良信息。
反馈该文档无法正常浏览。
举报该文档为重复文档。
推荐理由：
将文档分享至：
分享完整地址
文档地址：
粘贴到BBS或博客
flash地址：
支持嵌入FLASH地址的网站使用
html代码：
&embed src='/DocinViewer-4.swf' width='100%' height='600' type=application/x-shockwave-flash ALLOWFULLSCREEN='true' ALLOWSCRIPTACCESS='always'&&/embed&
450px*300px480px*400px650px*490px
支持嵌入HTML代码的网站使用
您的内容已经提交成功
您所提交的内容需要审核后才能发布，请您等待！
3秒自动关闭窗口扫一扫，访问微社区
只需一步，快速开始
后使用快捷导航没有帐号？
查看: 6709|回复: 17
vba ppt读取excel数据
锐币5420 元推广230 分
在线时间499 小时
主题帖子锐币
, 积分 3089, 距离下一级还需 1911 积分
, 积分 3089, 距离下一级还需 1911 积分
本帖最后由 banjinjiu 于
09:18 编辑
vba ppt读取excel数据，引用excel单元格数值。运行程序前，工具—引用—Microsoft Excel 11.0 Object Library。2003版测试通过，其他版本请测试，原理应该都是一样的，写的匆忙，错误之处敬请指正。Sub ppt读取excel()
'工具—引用—Microsoft Excel 11.0 Object Library
'ppt读取excel文件内容
Dim xlApp As Object
Dim xlWBK As Object
Dim xlSht As Object
Dim xlRng As Object
Dim C As Object
On Error Resume Next
Set xlApp = CreateObject(&Excel.Application&)
Set xlWBK = xlApp.Workbooks.Open(&C:\Documents and Settings\Administrator\桌面\1\xsmd.xls&)
Set xlSht = xlWBK.Worksheets(1)
With xlWBK
With xlSht
xlWBK.Worksheets(&Sheet1&).Activate
Shapes(&Text Box 5&).TextFrame.TextRange = Sheets.Application.ActiveSheet.Cells(355, 2).Value
MsgBox Sheets.Application.ActiveSheet.Cells(355, 2).Value
End With
End With
xlWBK.Close True 'False
xlApp.Quit
Set xlWBK = Nothing
Set xlApp = Nothing
End Sub复制代码文件已压缩成包，解压后还放在一个文件夹中。
09:18 上传
点击文件名下载附件
下载积分: 锐币 -2 元
29.23 KB, 下载次数: 206, 下载积分: 锐币 -2 元
<p id="rate_022" onmouseover="showTip(this)" tip="很给力!&锐币 + 40 元
" class="mtn mbn">
锐币279 元推广0 分
在线时间4 小时
主题帖子锐币
, 积分 69, 距离下一级还需 931 积分
, 积分 69, 距离下一级还需 931 积分
高手的帖，必须顶
锐币330066 元推广126320 分
在线时间7758 小时
主题帖子锐币
论坛老菜鸟
两个独单的人啊&&
手指要勤快，多逛多学多点鼠标，新手发帖请看：/forum.php?mod=viewthread&tid=3536&extra=page%3D1
锐币5420 元推广230 分
在线时间499 小时
主题帖子锐币
, 积分 3089, 距离下一级还需 1911 积分
, 积分 3089, 距离下一级还需 1911 积分
本帖最后由 banjinjiu 于
08:43 编辑
代码中有绝对路径，能否用相对路径。
若改成相对路径，确保ppt和excel文件同一文件夹下，改为Set xlWBK = xlApp.Workbooks.Open(Presentation.Path & &\xsmd.xls&)，我这测试成功。
这样就好了。&
这样就好了。&
锐币195347 元推广55460 分
在线时间3995 小时
主题帖子锐币
代码中有绝对路径，能否用相对路径。
文件已更新，原来找不到文件夹1。&
[]: sun_zhj在锐普PPT高手培训课堂认真听课，奖励 17 元 锐币.
学习中充实，充实中丰富。
锐币195347 元推广55460 分
在线时间3995 小时
主题帖子锐币
支持一下。
感谢孙兄支持&
学习中充实，充实中丰富。
锐币226 元推广0 分
在线时间8 小时
主题帖子锐币
, 积分 128, 距离下一级还需 872 积分
, 积分 128, 距离下一级还需 872 积分
高手绝对的高手VBA技巧值得深思
锐币525 元推广0 分
在线时间9 小时
主题帖子锐币
, 积分 164, 距离下一级还需 836 积分
, 积分 164, 距离下一级还需 836 积分
07没反应，先收下，再看看。谢谢。
锐币6594 元推广0 分
在线时间92 小时
主题帖子锐币
, 积分 1997, 距离下一级还需 3003 积分
, 积分 1997, 距离下一级还需 3003 积分
看来不错啊！！！
[]: songhan受到新版PPT软件的冲击，晕过去了！ 降了2 元 锐币.
锐币32782 元推广0 分
在线时间358 小时
主题帖子锐币
, 积分 12428, 距离下一级还需 7572 积分
, 积分 12428, 距离下一级还需 7572 积分
设计确实是一份艰苦的工作，咱先从模仿做起吧
[]: gh_1969做的PPT被微软总裁比尔盖茨看中了，得到奖金 9 元 锐币.
守卫精英勋章
无数个深夜，你的坚守让我们不会寂寞，因为有你，论坛才有快乐。
优秀会员勋章
优秀是对一个锐友最高的荣誉，是优秀的锐友成就了优秀的锐普。
2015奉献楷模勋章
锐普论坛勤劳的小蜜蜂，用自己的劳作丰富着论坛的果实。
灌水精英勋章
水是论坛的生命，是你的浇灌让锐普生机勃勃。
推广精英勋章
锐普有很多的宣传大使，是你们让更多的人获得了提升PPT的机会，感谢你们！
致富精英勋章
在一个公平环境里，总有一些人先富起来，颁发勋章，希望能够带动大家共同富裕。
智慧精英勋章
这是一批卓越的精英，眼光高、水平高，分享的东西也是不一般的高。
站长推荐 /1
2088套，30G，正版，锐普原创，够你用一辈子，只要9块9，快来下载。
&#30005;&#35805;&#21672;&#35810;
<span class="icoTl" title="客服电话&#8802
Powered by
&#30005;&#35805;&#21672;&#35810;
<span class="icoTl" title="客服电话&#8802