与非或逻辑组合匹配

micch

muou8 发表于 2019-1-18 14:25
老师 ，如果是  A&B/C   意思就是   选AB同时存在   或者  C存在的情况了

这个逻辑关系用代码来判断，总觉得有点绕，回头想想吧，ABCD可能是什么格式内容，4项还是可能更多项？

muou8

香川群子 发表于 2019-1-18 17:37
他们都是解决了你一楼举例的特定问题。

无法得到一个通用的算法。

老师 您的理解是对的，现在就是缺一个自动翻译逻辑一个算法。

一把小刀闯天下

'&->与、|->或、!->非 ，其它逻辑可自由添加，自己找规律，，，
Option Explicit

Sub test()
  Dim arr, brr, i, j, k, calc, mark, t, s
  Set calc = CreateObject("MSScriptControl.ScriptControl")
  calc.Language = "vbscript"
  arr = [e2:i7]: brr = [a3:b9]
  mark = Split("&, and ,|, or ,!, not", ",")
  For i = 2 To UBound(arr, 1)
    For j = 1 To UBound(brr, 1)
      t = brr(j, 2)
      For k = 0 To UBound(mark) Step 2
        t = Replace(t, mark(k), mark(k + 1))
      Next
      For k = 2 To UBound(arr, 2)
        If arr(i, k) = "X" Then
          t = Replace(t, arr(1, k), True)
        Else
          t = Replace(t, arr(1, k), False)
        End If
      Next
      If calc.Eval(t) Then s = s & "," & brr(j, 1)
    Next
    If Len(s) Then Debug.Print "{" & Mid(s, 2) & "}"
    s = vbNullString
  Next
End Sub

第一张表
序号	组合
1	A
2	A/B
3	-A/B
4	A&B&C
5	-(A&B&C)
6	(A&B) | D
7	A&B&C&D

muou8

一把小刀闯天下 发表于 2019-1-19 22:37
'&->与、|->或、!->非 ，其它逻辑可自由添加，自己找规律，，，
Option Explicit

谢谢老师，中间还有点小问题，我自己调试下，方法是正确的，谢谢！

lsdongjh

我的OFFICE是64位，所以感觉代码很长，主要是要处理一下64位环境下ScriptControl 的调用问题

1. Option Explicit
   
2. 
   
3. Dim sh As Worksheet
   
4. Dim arrRule As Variant
   
5. Dim arrSource As Variant
   
6. 
   
7. Sub Test()
   
8.     Dim oSC As Object
   
9.     Dim lngRow As Long, lngRow2 As Long
   
10.     Dim strTemp As String, strResult As String, arrResult As Variant
    
11. 
    
12.     InicData
    
13.     ReDim arrResult(LBound(arrSource) To UBound(arrSource), 1 To 2)
    
14. 
    
15.     Set oSC = CreateObjectx86("MSScriptControl.ScriptControl")
    
16.     oSC.Language = "VBScript"
    
17.    
    
18.     For lngRow = LBound(arrSource) To UBound(arrSource)
    
19.         strResult = ""
    
20.         For lngRow2 = LBound(arrRule) To UBound(arrRule)
    
21.             arrResult(lngRow, 1) = arrSource(lngRow, 1)
    
22.             strTemp = arrRule(lngRow2, 2)
    
23.             strTemp = Replace(strTemp, "@A@", arrSource(lngRow, 2))
    
24.             strTemp = Replace(strTemp, "@B@", arrSource(lngRow, 3))
    
25.             strTemp = Replace(strTemp, "@C@", arrSource(lngRow, 4))
    
26.             strTemp = Replace(strTemp, "@D@", arrSource(lngRow, 5))
    
27.             If oSC.Eval(strTemp) = True Then strResult = strResult & "," & arrRule(lngRow2, 1)
    
28.         Next
    
29.         arrResult(lngRow, 2) = Mid(strResult, 2)
    
30.     Next
    
31.    
    
32.     CreateObjectx86 , True
    
33.    
    
34.     sh.Range("B30").Resize(UBound(arrResult), 2) = arrResult
    
35. End Sub
    
36. 
    
37. Sub InicData()
    
38.     Dim strVal As String
    
39.     Dim lngRow As Long, lngCol As Long
    
40.    
    
41.     Set sh = Sheets("数据")
    
42.     arrRule = sh.Range("A3:B9")
    
43.     arrSource = sh.Range("E3:I7")
    
44.    
    
45.     For lngRow = LBound(arrRule) To UBound(arrRule)
    
46.         strVal = arrRule(lngRow, 2)
    
47.         strVal = UCase(Trim(strVal))
    
48.         strVal = Replace(strVal, "A", "@A@")
    
49.         strVal = Replace(strVal, "B", "@B@")
    
50.         strVal = Replace(strVal, "C", "@C@")
    
51.         strVal = Replace(strVal, "D", "@D@")
    
52.         strVal = Replace(strVal, "/", " Or ")
    
53.         strVal = Replace(strVal, "&", " And ")
    
54.         strVal = Replace(strVal, "|", " Or ")
    
55.         strVal = Replace(strVal, "-", " Not ")
    
56.         arrRule(lngRow, 2) = strVal
    
57.     Next
    
58.    
    
59.     For lngRow = LBound(arrSource) To UBound(arrSource)
    
60.         For lngCol = LBound(arrSource, 2) + 1 To UBound(arrSource, 2)
    
61.             strVal = arrSource(lngRow, lngCol)
    
62.             strVal = UCase(Trim(strVal))
    
63.             If strVal = "X" Then
    
64.                 strVal = "True"
    
65.             Else
    
66.                 strVal = "False"
    
67.             End If
    
68.             arrSource(lngRow, lngCol) = strVal
    
69.         Next
    
70.     Next
    
71.    
    
72.     sh.Range("K2").Resize(UBound(arrRule), UBound(arrRule, 2)) = arrRule
    
73.     sh.Range("N2").Resize(UBound(arrSource), UBound(arrSource, 2)) = arrSource
    
74.    
    
75. End Sub
    
76. 
    
77. Function CreateObjectx86(Optional sProgID, Optional bClose = False)
    
78.     Static oWnd As Object
    
79.     Dim bRunning As Boolean
    
80.     #If Win64 Then
    
81.         bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
    
82.         If bClose Then
    
83.             If bRunning Then oWnd.Close
    
84.             Exit Function
    
85.         End If
    
86.         If Not bRunning Then
    
87.             Set oWnd = CreateWindow()
    
88.             oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
    
89.         End If
    
90.         Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    
91.     #Else
    
92.         Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
    
93.     #End If
    
94. End Function
    
95. 
    
96. Function CreateWindow()
    
97.     Dim sSignature, oShellWnd, oProc
    
98.     On Error Resume Next
    
99.     sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    
100.     CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
     
101.     Do
     
102.         For Each oShellWnd In CreateObject("Shell.Application").Windows
     
103.             Set CreateWindow = oShellWnd.GetProperty(sSignature)
     
104.             If Err.Number = 0 Then Exit Function
     
105.             Err.Clear
     
106.         Next
     
107.     Loop
     
108. End Function
     
109. 
     
110. 
     

复制代码

lsdongjh

详见代码，主要是用ScriptControl处理，我的是64位，所以代码感觉很长，如果你是32位，非常简单的

1. Option Explicit
   
2. 
   
3. Dim sh As Worksheet
   
4. Dim arrRule As Variant
   
5. Dim arrSource As Variant
   
6. 
   
7. Sub Test()
   
8.     Dim objScript As Object
   
9.     Dim lngRow As Long, lngRow2 As Long
   
10.     Dim strTemp As String, strResult As String, arrResult As Variant
    
11. 
    
12.     InicData
    
13.     ReDim arrResult(LBound(arrSource) To UBound(arrSource), 1 To 2)
    
14. 
    
15.     Set objScript = CreateObjectx86("MSScriptControl.ScriptControl")
    
16.     objScript.Language = "VBScript"
    
17.    
    
18.     For lngRow = LBound(arrSource) To UBound(arrSource)
    
19.         strResult = ""
    
20.         For lngRow2 = LBound(arrRule) To UBound(arrRule)
    
21.             arrResult(lngRow, 1) = arrSource(lngRow, 1)
    
22.             strTemp = arrRule(lngRow2, 2)
    
23.             strTemp = Replace(strTemp, "@A@", arrSource(lngRow, 2))
    
24.             strTemp = Replace(strTemp, "@B@", arrSource(lngRow, 3))
    
25.             strTemp = Replace(strTemp, "@C@", arrSource(lngRow, 4))
    
26.             strTemp = Replace(strTemp, "@D@", arrSource(lngRow, 5))
    
27.             If objScript.Eval(strTemp) = True Then strResult = strResult & "," & arrRule(lngRow2, 1)
    
28.         Next
    
29.         arrResult(lngRow, 2) = Mid(strResult, 2)
    
30.     Next
    
31.    
    
32.     CreateObjectx86 , True
    
33.    
    
34.     sh.Range("B30").Resize(UBound(arrResult), 2) = arrResult
    
35. End Sub
    
36. 
    
37. Sub InicData()
    
38.     Dim strVal As String
    
39.     Dim lngRow As Long, lngCol As Long
    
40.    
    
41.     Set sh = Sheets("数据")
    
42.     arrRule = sh.Range("A3:B9")
    
43.     arrSource = sh.Range("E3:I7")
    
44.    
    
45.     For lngRow = LBound(arrRule) To UBound(arrRule)
    
46.         strVal = arrRule(lngRow, 2)
    
47.         strVal = UCase(Trim(strVal))
    
48.         strVal = Replace(strVal, "A", "@A@")
    
49.         strVal = Replace(strVal, "B", "@B@")
    
50.         strVal = Replace(strVal, "C", "@C@")
    
51.         strVal = Replace(strVal, "D", "@D@")
    
52.         strVal = Replace(strVal, "/", " Or ")
    
53.         strVal = Replace(strVal, "&", " And ")
    
54.         strVal = Replace(strVal, "|", " Or ")
    
55.         strVal = Replace(strVal, "-", " Not ")
    
56.         arrRule(lngRow, 2) = strVal
    
57.     Next
    
58.    
    
59.     For lngRow = LBound(arrSource) To UBound(arrSource)
    
60.         For lngCol = LBound(arrSource, 2) + 1 To UBound(arrSource, 2)
    
61.             strVal = arrSource(lngRow, lngCol)
    
62.             strVal = UCase(Trim(strVal))
    
63.             If strVal = "X" Then
    
64.                 strVal = "True"
    
65.             Else
    
66.                 strVal = "False"
    
67.             End If
    
68.             arrSource(lngRow, lngCol) = strVal
    
69.         Next
    
70.     Next
    
71.    
    
72. End Sub
    
73. 
    
74. Function CreateObjectx86(Optional sProgID, Optional bClose = False)
    
75.     Static oWnd As Object
    
76.     Dim bRunning As Boolean
    
77.     #If Win64 Then
    
78.         bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
    
79.         If bClose Then
    
80.             If bRunning Then oWnd.Close
    
81.             Exit Function
    
82.         End If
    
83.         If Not bRunning Then
    
84.             Set oWnd = CreateWindow()
    
85.             oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
    
86.         End If
    
87.         Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    
88.     #Else
    
89.         Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
    
90.     #End If
    
91. End Function
    
92. 
    
93. Function CreateWindow()
    
94.     Dim sSignature, oShellWnd, oProc
    
95.     On Error Resume Next
    
96.     sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    
97.     CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    
98.     Do
    
99.         For Each oShellWnd In CreateObject("Shell.Application").Windows
    
100.             Set CreateWindow = oShellWnd.GetProperty(sSignature)
     
101.             If Err.Number = 0 Then Exit Function
     
102.             Err.Clear
     
103.         Next
     
104.     Loop
     
105. End Function
     
106. 
     
107. 
     

复制代码

一把小刀闯天下

muou8 发表于 2019-1-21 09:13
谢谢老师，中间还有点小问题，我自己调试下，方法是正确的，谢谢！

33楼的贴图是错误的，复制的时候搞错了

你按第一行说明进行修改即可，或者你用文字说明逻辑我来给你写表达式，，，

muou8

一把小刀闯天下 发表于 2019-1-21 12:16
33楼的贴图是错误的，复制的时候搞错了

你按第一行说明进行修改即可，或者你用文字说明逻辑我来给你写 ...

谢谢老师，不用了，我结合了36楼老师的方法，防止在64位上无法运行，谢谢老师。