如何用VBA方法从其他表格中按条件查找提取数据？

罗超123

源数据表中的数据每日自动更新，但是包含了很多款产品，现在只需要提取1款产品的数据到B表中，之前一直用的Vlooup函数，数据量较大，所以很慢，希望用VBA来实现，求大神指点

mzbao

见附件
你在【每日需要更新的工作表】的B列输入的时候，代码会自动填写后面的内容
在B列直接粘贴多个，代码也可以自动填写多行

Sheet1中代码

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim Rng As Range
   
3.     If Target.Columns.Count = 1 Then
   
4.         If Target.Column = 2 Then
   
5.             For Each Rng In Target
   
6.                 If Len(Rng.Value) Then Call WriteData(Rng)
   
7.             Next
   
8.         End If
   
9.     End If
   
10. End Sub

复制代码

模块里代码

1. Public d
   
2. 
   
3. Sub ReadDataDic()
   
4.     Dim Path$, wb As Object, iRow%, wbArr, i%
   
5.    
   
6.     Path = ThisWorkbook.Path
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     Set wb = GetObject(Path & "\源数据表.xlsx")
   
9.     With wb.Sheets("Sheet1")
   
10.         iRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         If iRow < 2 Then Exit Sub
    
12.         wbArr = .Range("A2:G" & iRow).Value
    
13.     End With
    
14.     wb.Close   
    
15.     For i = 1 To iRow - 1
    
16.         d(wbArr(i, 2)) = wbArr(i, 4) & "|" & wbArr(i, 5) & "|" & wbArr(i, 6) & "|" & wbArr(i, 3)
    
17.     Next
    
18. End Sub
    
19. 
    
20. Sub WriteData(Rng As Range)
    
21.     Dim BatchCode$, arr, col%
    
22.    
    
23.     On Error Resume Next
    
24.     If Rng.Count > 1 Then Exit Sub
    
25.     d.Count
    
26.     If Err.Number = 424 Then Call ReadDataDic   
    
27.     BatchCode = Rng.Value
    
28.     If d.Exists(BatchCode) Then
    
29.         arr = Split(d(BatchCode), "|")
    
30.         For col = 1 To 4
    
31.             Rng.Offset(0, col) = arr(col - 1)
    
32.         Next
    
33.     Else
    
34.         MsgBox "源数据表没有样品批号" & BatchCode & "！", vbExclamation
    
35.     End If
    
36. End Sub

复制代码

罗超123

mzbao 发表于 2017-5-28 20:43
见附件
你在【每日需要更新的工作表】的B列输入的时候，代码会自动填写后面的内容
在B列直接粘贴多个，代 ...

牛逼&#128175;&#128077;

罗超123

mzbao 发表于 2017-5-28 20:43
见附件
你在【每日需要更新的工作表】的B列输入的时候，代码会自动填写后面的内容
在B列直接粘贴多个，代 ...

能不能根据测试项目进行筛选比如源数据表中国测试项目为“粒度-1”，在表2中直接根据关键字“粒度”进行提取数据而不是通过固定的列来提取？坐等大神回复

qironghua

mzbao 发表于 2017-5-28 20:43
见附件
你在【每日需要更新的工作表】的B列输入的时候，代码会自动填写后面的内容
在B列直接粘贴多个，代 ...

找了很久的功能，终于找到了~~ 谢谢层主~~

ljch1327

Err.Number = 424表示啥

710786507

请问各位大神，请问要如何修改，将提取的范围增加至800行，200列.

adud

虽然很久的代码了，但对我来说却是刚刚好。谢谢啊