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

一把小刀闯天下

'另外一种情况没写，就是小类中没有分号

Option Explicit

Sub test()
  Dim i, j, t, arr, brr, dic, key, s, tt, k
  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)
    dic.RemoveAll
    If InStr(brr(i, 1), "；") Then
      t = Split(brr(i, 1), "；")
      For j = 0 To UBound(t)
        t(j) = seach(arr, t(j))
        If InStr(t(j), ";") Then
          tt = Split(t(j), ";")
          For k = 0 To UBound(tt): dic(tt(k)) = dic(tt(k)) + 1: Next
        End If
      Next
      s = vbNullString
      For Each key In dic.keys
        If dic(key) = UBound(t) + 1 Then s = s & key & ";"
      Next
      If Len(s) Then s = Left(s, Len(s) - 1)
      brr(i, 1) = s
    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(s) Then seach = Left(seach, Len(seach) - 1)
End Function

梦月影

一把小刀闯天下 发表于 2018-7-10 15:02
'另外一种情况没写，就是小类中没有分号

Option Explicit

老师~我把C老师的10.1.5小类行删掉后，结果就不对了？

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim SH As Worksheet, strShName As String
   
5.     Dim lngRows As Long, lngRow As Long, strTemp As String
   
6.     Dim arrResult As Variant, strCondition As String, intCount As Integer
   
7.     Dim Conn As Object, Rst As Object, strPath As String
   
8.     Dim strConn As String, strSQL As String, strBasicSql As String
   
9.     Dim rgResult As Range
   
10.    
    
11.     strShName = "老师小类表"
    
12.     Set SH = Sheets(strShName)
    
13.    
    
14.     ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
15.     lngRows = SH.Range("I" & Rows.Count).End(xlUp).Row
    
16.     If lngRows < 2 Then Exit Sub '条件区域无值
    
17.     arrResult = SH.Range("I2:K" & lngRows)
    
18.     Set rgResult = SH.Range("I2")
    
19.    
    
20.     lngRows = SH.Range("C" & Rows.Count).End(xlUp).Row
    
21.     If lngRows < 2 Then Exit Sub '数据区域无值
    
22.     strShName = strShName & "$A1:C" & lngRows
    
23.    
    
24.     ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
25.     Set Conn = CreateObject("ADODB.Connection")
    
26.     Set Rst = CreateObject("ADODB.Recordset")
    
27.     strPath = ThisWorkbook.FullName
    
28.     Select Case Application.Version * 1
    
29.         Case Is <= 11
    
30.             strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
    
31.         Case Is >= 12
    
32.             strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
33.     End Select
    
34.     Conn.Open strConn
    
35. 
    
36.     ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
37.     strBasicSql = "SELECT 老师姓名 " & _
    
38.                   "FROM [@strShName@] " & _
    
39.                   "WHERE 小类 In (@strCondition@) " & _
    
40.                   "GROUP BY 老师姓名 " & _
    
41.                   "HAVING Count(小类) >= @intCount@ " & _
    
42.                   "ORDER BY 老师姓名;"
    
43.                   
    
44.     ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
45.     Application.ScreenUpdating = False
    
46.     Application.Cursor = xlWait
    
47.    
    
48.     For lngRow = LBound(arrResult) To UBound(arrResult)
    
49.         strTemp = arrResult(lngRow, 1)
    
50.         strTemp = Trim(strTemp)
    
51.         strTemp = Replace(strTemp, "；", ";") '将全角分号改为半角
    
52.         intCount = UBound(Split(strTemp, ";")) + 1 '计算条件数
    
53.         strTemp = Replace(strTemp, ";", Chr(34) & "," & Chr(34))
    
54.         strCondition = Chr(34) & strTemp & Chr(34)
    
55.         
    
56.         strSQL = Replace(strBasicSql, "@strShName@", strShName)
    
57.         strSQL = Replace(strSQL, "@strCondition@", strCondition)
    
58.         strSQL = Replace(strSQL, "@intCount@", intCount)
    
59.         
    
60.         Rst.Open strSQL, Conn, 3, 1 '执行查询，并将结果输出到记录集对象
    
61.         strTemp = ""
    
62.         If Rst.RecordCount > 0 Then
    
63.             Rst.movefirst
    
64.             Do Until Rst.EOF
    
65.                 strTemp = strTemp & ";" & Rst.Fields("老师姓名").Value
    
66.                 Rst.movenext
    
67.             Loop
    
68.         End If
    
69.         Rst.Close
    
70.         arrResult(lngRow, 3) = Mid(strTemp, 2)
    
71.     Next
    
72.     Set Rst = Nothing
    
73.     Set Conn = Nothing
    
74.    
    
75.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
76.     rgResult.Resize(UBound(arrResult), UBound(arrResult)) = arrResult
    
77.     MsgBox "OK"
    
78.    
    
79.     Application.ScreenUpdating = True
    
80.     Application.Cursor = xlDefault
    
81. 
    
82.    
    
83. End Sub

复制代码

lsdongjh

详见附件： 查找结果.rar (20.63 KB, 下载次数: 6)

2018-7-10 15:15 上传

点击文件名下载附件

一把小刀闯天下

梦月影 发表于 2018-7-10 15:06
老师~我把C老师的10.1.5小类行删掉后，结果就不对了？

'已修改

Option Explicit

Sub test()
  Dim i, j, t, arr, brr, dic, key, s, tt, k
  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)
    dic.RemoveAll
    If InStr(brr(i, 1), "；") Then
      t = Split(brr(i, 1), "；")
      For j = 0 To UBound(t)
        t(j) = seach(arr, t(j))
        If InStr(t(j), ";") Then
          tt = Split(t(j), ";")
          For k = 0 To UBound(tt): dic(tt(k)) = dic(tt(k)) + 1: Next
        Else
          If Len(t(j)) > 0 Then dic(t(j)) = dic(t(j)) + 1
        End If
      Next
      s = vbNullString
      For Each key In dic.keys
        If dic(key) = UBound(t) + 1 Then s = s & key & ";"
        Debug.Print dic(key)
      Next
      If Len(s) Then s = Left(s, Len(s) - 1)
      brr(i, 1) = s
    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 15:16
'已修改

Option Explicit

谢谢大神~！

梦月影

lsdongjh 发表于 2018-7-10 15:15
详见附件：

万分感谢！

魂断蓝桥

企业1        10.1.1；10.1.3；10.1.5                A；B

为什么是ab而不是abc呢