Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1650|回复: 2

[已解决]新手求助,数据引用发现重复项不能引用问题???????

[复制链接]
发表于 2016-6-11 12:12 | 显示全部楼层 |阅读模式
本帖最后由 daxindianqi 于 2016-6-11 15:01 编辑

求助:


数据刷新的作用为以D列为索引,查找本表目录下的“data.xls”文件中相同意义的值并赋值在本表相应单元内;

问题:如D列有重复项,则执行数据刷新后只能在最下部所在行的单元格才能引用。


例如:D4与D9有重复,执行数据刷新后只能在D9单元格所在的行引用,正确的引用是所有D列存在的数据都要被引用。
Private Sub CommandButton1_Click()
Dim Arr, myPath$, myName$, Arr1, Myr&, d, Myr1&, m&
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Sheets("分项报价").Activate
Myr = Cells(Rows.Count, 4).End(xlUp).Row
Range("e4:m" & Myr).ClearContents
Arr = Range("a4:m" & Myr)
For i = 1 To UBound(Arr)
If Arr(i, 4) <> "" Then d(Arr(i, 4)) = i
Next
myPath = ThisWorkbook.Path & "\"
myName = Dir(myPath & "data.xls")

With GetObject(myPath & myName)
With .Sheets("data")
Myr1 = .Cells(.Rows.Count, 4).End(xlUp).Row
Arr1 = .Range("a1:J" & Myr1) '
For i = 1 To UBound(Arr1)
If d.Exists(Arr1(i, 4)) Then '
m = d(Arr1(i, 4))
Arr(m, 2) = Arr1(i, 2)
Arr(m, 3) = Arr1(i, 3)
Arr(m, 5) = Arr1(i, 5)
Arr(m, 7) = Arr1(i, 7)
Arr(m, 9) = Arr1(i, 10)
End If
Next
End With
.Close False
End With

Range("a4:m" & Myr) = Arr
For i = 1 To UBound(Arr)
If Arr(i, 2) <> "" Then Cells(i + 3, 8) ="=rc[-1]*rc[-2]"
If Arr(i, 2) <> "" Then Cells(i + 3, 10) ="=rc[-3]*rc[2]"
If Arr(i, 2) <> "" Then Cells(i + 3, 11) ="=rc[-1]*rc[1]"
Next
Application.ScreenUpdating = True
End Sub

最佳答案
2016-6-11 14:18
代码如下:
  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, 7) = 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, 10) = "=rc[-3]*rc[2]"
  35.         If Arr(i, 2) <> "" Then Cells(i + 3, 11) = "=rc[-1]*rc[1]"
  36.     Next
  37.     Application.ScreenUpdating = True
  38. End Sub
复制代码

试验程序.rar

30.81 KB, 下载次数: 21

发表于 2016-6-11 14:18 | 显示全部楼层    本楼为最佳答案   
代码如下:
  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, 7) = 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, 10) = "=rc[-3]*rc[2]"
  35.         If Arr(i, 2) <> "" Then Cells(i + 3, 11) = "=rc[-1]*rc[1]"
  36.     Next
  37.     Application.ScreenUpdating = True
  38. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
daxindianqi + 1 很给力

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-6-11 14:54 | 显示全部楼层
老司机带带我 发表于 2016-6-11 14:18
代码如下:

非常好用,正在学习和理解中,感谢。
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 17:37 , Processed in 0.550881 second(s), 18 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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