求助大侠 用VBA多条件查找判断超级难。有没有好的方法~

ykcbf1100

练习一下，比较简单吧，用一个字典就搞定了。

ykcbf1100

练习。。。

1. Sub ykcbf()   '//2024.12.10
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         c = .UsedRange.Columns.Count
   
7.         arr = .[a1].Resize(r, c)
   
8.         .UsedRange.Offset(13).Interior.ColorIndex = 0
   
9.         .UsedRange.Offset(13, 1).ClearContents
   
10.         For i = 2 To 11
    
11.             For j = 2 To UBound(arr, 2)
    
12.                 If arr(i, j) <> Empty Then
    
13.                     s = arr(i, 1) & "|" & j
    
14.                     d(s) = 1
    
15.                 End If
    
16.             Next
    
17.         Next
    
18.         For i = 14 To r
    
19.             For j = 2 To UBound(arr, 2)
    
20.                 st = Split(arr(i, 1), ",")
    
21.                 n = 0
    
22.                 For x = 0 To UBound(st)
    
23.                     s = st(x) & "|" & j
    
24.                     n = n + d(s)
    
25.                 Next
    
26.                 Set Rng = .Cells(i, j)
    
27.                 If n Then
    
28.                     Rng.Value = "NG"
    
29.                     Rng.Interior.ColorIndex = 3
    
30.                 Else
    
31.                     Rng.Value = "YES"
    
32.                 End If
    
33.             Next
    
34.         Next
    
35.     End With
    
36.     Set d = Nothing
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "OK！"
    
39. End Sub
    
40. 
    

复制代码

micch

zhang139 发表于 2021-6-20 10:05
这是公式版本 做出来的，能不能用VBA生产出来。
=IF(LEFT(IFERROR(VLOOKUP(--MID($A14,1,1),$A$1:$HN$11,C ...

只看公式改一下

1. =IF(LEFT(CONCAT(IFERROR(VLOOKUP(--TEXTSPLIT($A14,","),$A$1:$HN$11,COLUMN(),0),"")),1)="A","NG","YES")

复制代码

micch

1. =IF(OR(INDEX(B$2:B$11,TEXTSPLIT($A14,","))="A"),"NG","YES")

复制代码

简化公式后，代码实现起来就简单多了

micch

1. Sub Main()
   
2.     ar = Sheet2.Range("A2:Ho11").Value
   
3.     br = Sheet2.Range("A14:A265").Value
   
4.     ReDim cr(1 To UBound(br), 2 To UBound(ar, 2))
   
5.     For i = 1 To UBound(br)
   
6.     For k = 2 To UBound(ar, 2)
   
7.         cr(i, k) = "YES"
   
8.         For Each j In Split(br(i, 1), ",")
   
9.             If ar(Val(j), k) = "A" Then cr(i, k) = "NG": Exit For
   
10.         Next
    
11.     Next
    
12.     Next
    
13.     Range("B14").Resize(i - 1, k - 2).Value = cr
    
14. End Sub

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
6.         arr = .Range("b2").Resize(10, c - 1)
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         brr = .Range("a14").Resize(r - 13, 1)
   
9.         ReDim crr(1 To UBound(brr), 1 To UBound(arr, 2))
   
10.         For i = 1 To UBound(brr)
    
11.             xm = Split(brr(i, 1), ",")
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 For q = 0 To UBound(xm)
    
14.                     If arr(Val(xm(q)), j) = "A" Then
    
15.                         Exit For
    
16.                     End If
    
17.                 Next
    
18.                 If q > UBound(xm) Then
    
19.                     crr(i, j) = "NG"
    
20.                 Else
    
21.                     crr(i, j) = "YES"
    
22.                 End If
    
23.             Next
    
24.         Next
    
25.         .Range("b14").Resize(UBound(crr), UBound(crr, 2)) = crr
    
26.     End With
    
27. End Sub
    

复制代码

chxw68

今天窗外下雪，参与一下。