VBA根据条件，将符合条件的赋值，在另外区域标识出来。有劳各位老师看看，谢谢！！

13602822168

VBA根据条件，将符合条件的赋值，在另外区域标识出来。有劳各位老师看看，谢谢！！

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, iStart&, i&, j&, r&, k&, Rng As Range, vTemp
   
    Application.ScreenUpdating = False
   
    r = Cells(Rows.Count, "R").End(xlUp).Row
    ar = Range("R6:AG" & r).Value
   
    vTemp = [AJ2].Value: r = [AJ3].Value + 1
    With Range("AI6").Resize(UBound(ar), UBound(ar, 2))
        .Clear
        For j = 1 To UBound(ar, 2)
            For i = 1 To UBound(ar)
                If ar(i, j) = vTemp Then
                    iStart = i + r
                    For k = iStart To UBound(ar) Step r
                        If ar(k, j) = vTemp Then
                            With .Cells(k, j)
                                .Value = 12
                                .Interior.Color = vbYellow
                            End With
                        End If
                    Next k
                    Exit For
                End If
            Next i
        Next j
    End With
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

...............

ykcbf1100

这个题目应该做到过了。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.8.25
   
2.     r = Cells(Rows.Count, "s").End(3).Row
   
3.     arr = [a1].Resize(r, 33)
   
4.     [aj6:ax10000].Clear
   
5.     st = [aj2].Value
   
6.     num = [aj3].Value
   
7.     On Error Resume Next
   
8.     For j = 18 To UBound(arr, 2)
   
9.         For i = UBound(arr) To 6 Step -1
   
10.             If arr(i, j) = st Then
    
11.                 Set Rng = Cells(i, j)
    
12.                 If Rng.Interior.ColorIndex <> xlNone And i - num > 6 Then
    
13.                     Set Rng1 = Rng.Offset(-num - 1)
    
14.                     If Rng1.Interior.ColorIndex <> xlNone Then
    
15.                         Cells(i, j + 17).Value = 12
    
16.                         Cells(i, j + 17).Interior.ColorIndex = 6
    
17.                     End If
    
18.                 End If
    
19.             End If
    
20.         Next
    
21.     Next
    
22. End Sub
    

复制代码

13602822168

gwjkkkkk 发表于 2024-8-25 09:35
...............

好像不对，结果不对？？