在VBA中如何将同时满足A列B列条件的不重复名称充填到另一列

TZJ133

请教各位大师,我的问题有两个:1    想用VBA在"质量"页的B6至B51中,对"引用"页中同时满足:A列名称含有"铅*",B列中又不重复名称进行填充;

2    想在"质量"页的I6至I51中,对满足三个条件的进行引用:  "引用"页A列中含有"铅*","引用"页B列中对应相应的"质量"页的B6至B51的名称,"引用"页中BO至BU区域为四级品以下的该列的元素;

TZJ133

求大师帮助

TZJ133

求大师帮助

TZJ133

求求大师们

TZJ133

大师有空帮我吗

grf1973

1. Sub 填充()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Arr = Sheets("引用").[a1].CurrentRegion
   
4.     Dim pj(67 To 73)   'BO到BU列超标的元素名
   
5.     For i = 67 To 73
   
6.         pj(i) = Split(Arr(1, i), "(")(0)
   
7.     Next
   
8.     For i = 3 To UBound(Arr)
   
9.         x = Arr(i, 2)
   
10.         If Arr(i, 1) Like "铅*" And x <> "" Then
    
11.             d(x) = d(x) & ""
    
12.             For j = 67 To 73 'BO到BU列
    
13.                 y = Arr(i, j)
    
14.                 If InStr("一级二级三级", y) > 0 Or y = "四级品以下" Then
    
15.                     If d(x) = "" Then
    
16.                         d(x) = pj(j)
    
17.                     ElseIf InStr(d(x), pj(j)) = 0 Then
    
18.                         d(x) = d(x) & "," & pj(j)
    
19.                     End If
    
20.                 End If
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     With ActiveSheet
    
25.         r = 22     '显示位置，自行调节
    
26.         .Cells(r, 2).Resize(d.Count, 1) = Application.Transpose(d.keys)   '去重的公司名
    
27.         .Cells(r, "I").Resize(d.Count, 1) = Application.Transpose(d.items)     '超标元素
    
28.     End With
    
29. End Sub
    

复制代码

TZJ133

非常感谢,真的非常感谢!

TZJ133

非常非常感谢!