多条件多结果查询~大神求助

梦月影

老师姓名	体系	小类					企业名称	所需小类		符合要求的老师
A	ISO9001	10.1.1					企业1	10.1.1；10.1.3；10.1.5		A；B
A	ISO9001	10.1.2					企业2	10.1.1；10.1.3		A；B;C
A	ISO9001	10.1.3					企业3	10.1.1；10.1.3；10.1.5		A；B
A	ISO9001	10.1.4
A	ISO9001	10.1.5
B	ISO9001	10.1.1
B	ISO9001	10.1.2
B	ISO9001	10.1.3
C	ISO9001	10.1.1
C	ISO9001	10.1.2
C	ISO9001	10.1.3
C	ISO9001	10.1.4
C	ISO9001	10.1.5

求助，根据所需小类里面的内容查找左边符合要求的老师，并把老师结果反馈到K列单元格内。如上图，研究半天感觉函数满足不了，需要VBA实现~

梦月影

求帮助~~~现在几百条需要查询，工作量太恐怖了~

lenghonghai601

数据有重复啊，10.1.1到底算是A还是C啊，怎么分企业1，企业2，企业3

一把小刀闯天下

'跟示例结果不同，规则有问题？

Option Explicit

Sub test()
  Dim i, j, t, arr, brr, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  brr = Range("i2:i" & Cells(Rows.Count, "i").End(xlUp).Row)
  For i = 1 To UBound(brr, 1)
    If InStr(brr(i, 1), "；") Then
      t = Split(brr(i, 1), "；")
      For j = 0 To UBound(t): t(j) = seach(arr, t(j)): Next
      brr(i, 1) = Join(t, ";")
    Else
      brr(i, 1) = seach(arr, brr(i, 1))
    End If
  Next
  For i = 1 To UBound(brr, 1)
    If InStr(brr(i, 1), ";") Then
      dic.RemoveAll: t = Split(brr(i, 1), ";")
      For j = 0 To UBound(t): dic(t(j)) = vbNullString: Next
      brr(i, 1) = Join(dic.keys, ";")
    End If
  Next
  [l2].Resize(UBound(brr, 1)) = brr
End Sub

Function seach(arr, s) As String
  Dim i
  For i = 2 To UBound(arr, 1)
    If arr(i, 3) = s Then seach = seach & arr(i, 1) & ";"
  Next
  If Len(seach) Then seach = Left(seach, Len(seach) - 1)
End Function

梦月影

一把小刀闯天下 发表于 2018-7-10 14:21
'跟示例结果不同，规则有问题？

Option Explicit

大神~结果有点问题，所需小类里的小类需要老师都符合才出现老师的姓名，企业1符合条件小类的老师有A;C。企业2符合条件小类的老师A;B;C企业3的老师是A;C。B老师没有10.1.5，所以企业1和3没有他

梦月影

lenghonghai601 发表于 2018-7-10 14:12
数据有重复啊，10.1.1到底算是A还是C啊，怎么分企业1，企业2，企业3

1.老师+小类是唯一的。每个小类可以有很多老师拥有
2.每个企业都有自己的小类需求，需要把所有小类都符合的老师筛选出来。

lsdongjh

是全部符合条件的老师，还是只要符合一个小项？？
1、如果符合一个小项，那么【企业1】的应该是：ABC
2、如果全部符合，那么【企业1】的应该是：AC

越看越晕~~

梦月影

lsdongjh 发表于 2018-7-10 14:31
是全部符合条件的老师，还是只要符合一个小项？？
1、如果符合一个小项，那么【企业1】的应该是：ABC
2、 ...

是的~您说的对~我附件结果错了,企业1和3符合的老师是A；C

lenghonghai601

1. Sub test()
   
2. Dim d As Object, arr, brr, crr(), i&, j&, m&, rng As Range
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. brr = Sheet1.Range("h1").CurrentRegion
   
6. ReDim crr(1 To UBound(brr) - 1)
   
7. For i = 2 To UBound(brr)
   
8.     If InStr(brr(i, 2), "；") Then
   
9.         x = Split(brr(i, 2), "；")
   
10.         For j = 0 To UBound(x)
    
11.             Set rng = Sheet1.Range("a1").CurrentRegion.Find(x(j), lookat:=xlWhole)
    
12.             s = rng.Address
    
13.             If Not rng Is Nothing Then
    
14.                 Do
    
15.                     crr(i - 1) = crr(i - 1) & "；" & arr(rng.Row, 1)
    
16.                   Set rng = Sheet1.Range("a1").CurrentRegion.FindNext(rng)
    
17.                 Loop While Not rng Is Nothing And rng.Address <> s
    
18.             End If
    
19.         Next j
    
20.     End If
    
21. Next i
    
22. For i = 1 To UBound(crr)
    
23.     crr(i) = Right(crr(i), Len(crr(i)) - 1)
    
24.     x = Split(crr(i), "；")
    
25.     For j = 0 To UBound(x)
    
26.     d(x(j)) = ""
    
27.     Next j
    
28.     crr(i) = Join(d.keys, "；")
    
29. Next i
    
30. Range("k2").Resize(UBound(crr), 1) = WorksheetFunction.Transpose(crr)
    
31. End Sub
    

复制代码

梦月影

lenghonghai601 发表于 2018-7-10 14:45

老师~每家企业所需小类是需要老师全部符合~出来的结果应该是
企业1：A;C
企业2：A;B;C
企业3 :A;C
B老师没有10.1.5的小类，所以企业1和3不符合要求