请教各位老师！VBA根据数值和间隔，找出并标出来。

13602822168

请教各位老师！VBA根据数值和间隔，找出并标出来。谢谢！！！

gwjkkkkk

感觉模拟结果看不出有什么规则 。。。

13602822168

gwjkkkkk 发表于 2024-8-21 18:10
感觉模拟结果看不出有什么规则 。。。

根据X1数值和X2间隔行数

ykcbf1100

原模拟结果有误（标色的都算进去了），请自行验证。

ykcbf1100

参与一下。。。

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

复制代码

jaxxcyh

看不懂，不知道要表达什么

13602822168

ykcbf1100 发表于 2024-8-21 18:58
参与一下。。。

感谢！！！！！！感谢！！！！！

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, iStart&, i&, j&, r&, k&, Rng As Range, vTemp
   
    Application.ScreenUpdating = False
   
    r = Cells(Rows.Count, "I").End(xlUp).Row
    ar = Range("I2:U" & r).Value
   
    vTemp = [x1].Value: r = [x2].Value + 1
    With Range("Y2").Resize(UBound(ar), UBound(ar, 2))
        .Clear
        .Interior.Color = xlNone
        For j = 1 To UBound(ar, 2)
            For i = r 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 = 1
                                .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

难道是这样吗？

13602822168

gwjkkkkk 发表于 2024-8-21 19:40
难道是这样吗？

谢谢帮助！！！！非常感谢！！！！！