设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › VBA未入门问题：代码问题求助 引用其他工作簿与本地工作 ...
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2008|回复: 4

[已解决]VBA未入门问题：代码问题求助 引用其他工作簿与本地工作表！

[复制链接]
发表于 2016-6-11 16:30 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
各位老师有一个小白的问题 请教：

下面的程序是引用当前工作簿目录下其它工作簿数据的代码，我如果想改成引用同一工作簿中“Sheets("基础数据")”工作表的数据该怎样写代码？

代码如下：
  1. Private Sub CommandButton1_Click()
  2.     Dim Arr, myPath$, myName$, Arr1, Myr&, d, Myr1&, m&
  3.     Application.ScreenUpdating = False
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.     Sheets("分项报价").Activate
  6.     Myr = Cells(Rows.Count, 4).End(xlUp).Row
  7.     Range("e4:m" & Myr).ClearContents
  8.     Arr = Range("a4:m" & Myr)
  9.     myPath = ThisWorkbook.Path & ""
  10.     myName = Dir(myPath & "data.xls")
  11.     With GetObject(myPath & myName)
  12.         With .Sheets("data")
  13.             Myr1 = .Cells(.Rows.Count, 4).End(xlUp).Row
  14.             Arr1 = .Range("a1:J" & Myr1)                         '
  15.              For i = 1 To UBound(Arr1)
  16.                 d(Arr1(i, 4)) = i
  17.             Next
  18.         End With
  19.         
  20.     End With
  21.     For i = 1 To Myr - 3
  22.         If d.Exists(Arr(i, 4)) Then
  23.             m = d(Arr(i, 4))
  24.             Arr(i, 2) = Arr1(m, 2)
  25.             Arr(i, 3) = Arr1(m, 3)
  26.             Arr(i, 5) = Arr1(m, 5)
  27.             Arr(i, 10) = Arr1(m, 7)
  28.             Arr(i, 9) = Arr1(m, 10)
  29.         End If
  30.     Next
  31.     Range("a4:m" & Myr) = Arr
  32.     For i = 1 To UBound(Arr)
  33.         If Arr(i, 2) <> "" Then Cells(i + 3, 8) = "=rc[-1]*rc[-2]"
  34.         If Arr(i, 2) <> "" Then Cells(i + 3, 7) = "=rc[3]*rc[5]"
  35.         If Arr(i, 2) <> "" Then Cells(i + 3, 11) = "=rc[-1]*rc[-5]"
  36.     Next
  37.     Application.ScreenUpdating = True
  38. End Sub
复制代码
最佳答案
月排行榜 / 总排行榜
xdragon
2016-6-11 17:02
  1. Private Sub CommandButton1_Click()
  2.     Dim Arr, myPath$, myName$, Arr1, Myr&, d, Myr1&, m&
  3.     Application.ScreenUpdating = False
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.     Sheets("分项报价").Activate
  6.     Myr = Cells(Rows.Count, 4).End(xlUp).Row
  7.     Range("e4:m" & Myr).ClearContents
  8.     Arr = Range("a4:m" & Myr)

  10.     With Sheets("基础数据")
  11.         Myr1 = .Cells(.Rows.Count, 4).End(xlUp).Row
  12.         Arr1 = .Range("a1:J" & Myr1)                         '
  13.          For i = 1 To UBound(Arr1)
  14.             d(Arr1(i, 4)) = i
  15.         Next
  16.     End With
  17.         
  18.     For i = 1 To Myr - 3
  19.         If d.Exists(Arr(i, 4)) Then
  20.             m = d(Arr(i, 4))
  21.             Arr(i, 2) = Arr1(m, 2)
  22.             Arr(i, 3) = Arr1(m, 3)
  23.             Arr(i, 5) = Arr1(m, 5)
  24.             Arr(i, 10) = Arr1(m, 7)
  25.             Arr(i, 9) = Arr1(m, 10)
  26.         End If
  27.     Next
  28.     Range("a4:m" & Myr) = Arr
  29.     For i = 1 To UBound(Arr)
  30.         If Arr(i, 2) <> "" Then Cells(i + 3, 8) = "=rc[-1]*rc[-2]"
  31.         If Arr(i, 2) <> "" Then Cells(i + 3, 7) = "=rc[3]*rc[5]"
  32.         If Arr(i, 2) <> "" Then Cells(i + 3, 11) = "=rc[-1]*rc[-5]"
  33.     Next
  34.     Application.ScreenUpdating = True
  35. End Sub
复制代码
刚才没注意，with 后面的sheets前多了个点。哈哈
工作表

相关帖子

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
xdragon
发表于 2016-6-11 16:51 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上

  2. Private Sub CommandButton1_Click()
  3.     Dim Arr, myPath$, myName$, Arr1, Myr&, d, Myr1&, m&
  4.     Application.ScreenUpdating = False
  5.     Set d = CreateObject("Scripting.Dictionary")
  6.     Sheets("分项报价").Activate
  7.     Myr = Cells(Rows.Count, 4).End(xlUp).Row
  8.     Range("e4:m" & Myr).ClearContents
  9.     Arr = Range("a4:m" & Myr)

  11.     With .Sheets("基础数据")
  12.         Myr1 = .Cells(.Rows.Count, 4).End(xlUp).Row
  13.         Arr1 = .Range("a1:J" & Myr1)                         '
  14.          For i = 1 To UBound(Arr1)
  15.             d(Arr1(i, 4)) = i
  16.         Next
  17.     End With
  18.         
  19.     For i = 1 To Myr - 3
  20.         If d.Exists(Arr(i, 4)) Then
  21.             m = d(Arr(i, 4))
  22.             Arr(i, 2) = Arr1(m, 2)
  23.             Arr(i, 3) = Arr1(m, 3)
  24.             Arr(i, 5) = Arr1(m, 5)
  25.             Arr(i, 10) = Arr1(m, 7)
  26.             Arr(i, 9) = Arr1(m, 10)
  27.         End If
  28.     Next
  29.     Range("a4:m" & Myr) = Arr
  30.     For i = 1 To UBound(Arr)
  31.         If Arr(i, 2) <> "" Then Cells(i + 3, 8) = "=rc[-1]*rc[-2]"
  32.         If Arr(i, 2) <> "" Then Cells(i + 3, 7) = "=rc[3]*rc[5]"
  33.         If Arr(i, 2) <> "" Then Cells(i + 3, 11) = "=rc[-1]*rc[-5]"
  34.     Next
  35.     Application.ScreenUpdating = True
  36. End Sub
复制代码
没文件，测试不了，楼主你自己测试吧
回复

使用道具 举报

 楼主| 发表于 2016-6-11 17:00 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
xdragon 发表于 2016-6-11 16:51
没文件，测试不了，楼主你自己测试吧

谢谢你的帮忙，不好意思刚才在整理文件，这是针对这段代码的文件，测试后出错！

data.rar

23.68 KB, 下载次数: 5
回复

使用道具 举报

xdragon
发表于 2016-6-11 17:02 | 显示全部楼层    本楼为最佳答案   
  1. Private Sub CommandButton1_Click()
  2.     Dim Arr, myPath$, myName$, Arr1, Myr&, d, Myr1&, m&
  3.     Application.ScreenUpdating = False
  4.     Set d = CreateObject("Scripting.Dictionary")
  5.     Sheets("分项报价").Activate
  6.     Myr = Cells(Rows.Count, 4).End(xlUp).Row
  7.     Range("e4:m" & Myr).ClearContents
  8.     Arr = Range("a4:m" & Myr)

  10.     With Sheets("基础数据")
  11.         Myr1 = .Cells(.Rows.Count, 4).End(xlUp).Row
  12.         Arr1 = .Range("a1:J" & Myr1)                         '
  13.          For i = 1 To UBound(Arr1)
  14.             d(Arr1(i, 4)) = i
  15.         Next
  16.     End With
  17.         
  18.     For i = 1 To Myr - 3
  19.         If d.Exists(Arr(i, 4)) Then
  20.             m = d(Arr(i, 4))
  21.             Arr(i, 2) = Arr1(m, 2)
  22.             Arr(i, 3) = Arr1(m, 3)
  23.             Arr(i, 5) = Arr1(m, 5)
  24.             Arr(i, 10) = Arr1(m, 7)
  25.             Arr(i, 9) = Arr1(m, 10)
  26.         End If
  27.     Next
  28.     Range("a4:m" & Myr) = Arr
  29.     For i = 1 To UBound(Arr)
  30.         If Arr(i, 2) <> "" Then Cells(i + 3, 8) = "=rc[-1]*rc[-2]"
  31.         If Arr(i, 2) <> "" Then Cells(i + 3, 7) = "=rc[3]*rc[5]"
  32.         If Arr(i, 2) <> "" Then Cells(i + 3, 11) = "=rc[-1]*rc[-5]"
  33.     Next
  34.     Application.ScreenUpdating = True
  35. End Sub
复制代码
刚才没注意，with 后面的sheets前多了个点。哈哈
回复

使用道具 举报

 楼主| 发表于 2016-6-11 17:09 | 显示全部楼层
xdragon 发表于 2016-6-11 17:02
刚才没注意，with 后面的sheets前多了个点。哈哈

恩 我刚才已经改好了 谢谢，以后有问题再请教。
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-28 11:27 , Processed in 0.267354 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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