VBA查找对应数据复制

Irisforever · 发表于 2018-8-20 23:06

请大神帮忙利用VBA完成以下效果：

描述： 1. 附件有三张sheet，第一张sheet为设定查询的sheet，使用时可以将任意item输入到A2以下的单元格内。
         2. 第二张为数据总表，所有item的信息都在其中且不重复
         3. 第三张为效果示意

目标： 1. 使用VBA查询放在sheet1中的item，找到在数据总表中的相关信息，复制到新sheet中。
         2. 对于在查询sheet中有，但数据总表中没有的item，需要在新sheet中保留该item名称，并且在后面每一个单元格内输入数字“0”

跪谢各位！

abc123281 · 发表于 2018-8-21 01:32

很少见过这种查询的

不知道为什么 · 发表于 2018-8-21 08:34

如图

不知道为什么 · 发表于 2018-8-21 08:36

参考

lsc900707 · 发表于 2018-8-21 09:00

查询结果直接放在查询表里不好吗？

lsc900707 · 发表于 2018-8-21 09:11

Sub gj23w98()
Set d = CreateObject("scripting.dictionary")
With Sheet2
arr = .[a1].CurrentRegion
m = UBound(arr): n = UBound(arr, 2)
For i = 2 To m
For j = 2 To n
s = arr(i, 1) & arr(1, j)
d(s) = arr(i, j)
Next
Next
End With
With Sheet3
.[a1].CurrentRegion.Offset(1).ClearContents
Range("a2:a" & Rows.Count).Copy .[a2]
brr = .[a1].CurrentRegion
For i = 2 To UBound(brr)
For j = 2 To UBound(brr, 2)
s = brr(i, 1) & brr(1, j)
If d.exists(s) Then
brr(i, j) = d(s)
Else
brr(i, j) = 0
End If
Next
Next
.[a1].CurrentRegion = brr
End With
End Sub

复制代码

lsc900707 · 发表于 2018-8-21 09:13

附件供参考：

Irisforever · 发表于 2018-8-21 23:35

不知道为什么发表于 2018-8-21 08:36
参考

强者无敌！非常感谢！

Irisforever · 发表于 2018-8-21 23:35

lsc900707 发表于 2018-8-21 09:13
附件供参考：

谢谢你的回答！非常感谢！

lsc900707 · 发表于 2018-8-22 05:42

Irisforever 发表于 2018-8-21 23:35
强者无敌！非常感谢！

可以直接给予“评分”的！

		自动登录	找回密码
密码			免费注册

[求助] VBA查找对应数据复制