VBA code for tagging adjacent cell after crossing certain value

[MrSak87]

Hey Experts,

I have a very large data set in which I need a VBA code to extract a value when a certain number is crossed. A simplified example would be

D Time0 1
2 2
2.5 3
3.5 4
4.1 5
4.2 6
8.2 7
9.3 8
10.1 9
11.2 10
13.5 11
13.2 12
11.1 13
10.2 14
9.6 15
5.2 16
2.1 17
2.5 18
2.8 19
3.6 20
5.8 21
9 22
10.2 23
12 24

In the example above, the code would populate every time the value 10 was crossed/or the value that is closest to it, could be 9.99. So in a different part of the sheet (say C1) the following values would be plotted

D Time
10.1 9
10.2 14
10.2 23

One last thing is the value 10 needs to be changeable when I run it on different data sets.

Is this possible!? I'm on a boat in the middle of the sea where the internet is very limited. Cry me a river

Thank you for any help

 

[tsonko]

Hi, this should work.
You can extract the values you are after by changing ll (lower limit) and ul (upper limit).

Sub numberCrossed2()


Application.ScreenUpdating = False


Dim rng As Range, i As Long, ll As Range, ul As Range
Dim lastRowD As Integer


Set rng = Worksheets("Sheet3").Range("A2")
Set ll = Worksheets("Sheet3").Range("H1")
Set ul = Worksheets("Sheet3").Range("H2")


i = 0
lastRowD = Cells(Rows.Count, "D").End(xlUp).Row


Do While rng.Offset(i) <> Empty


    If rng.Offset(i) >= ll And rng.Offset(i) <= ul Then
        Cells(lastRowD + 1, "D") = rng.Offset(i, 0)
        Cells(lastRowD + 1, "E") = rng.Offset(i, 1)
        
        lastRowD = lastRowD + 1
        
    End If
    
    i = i + 1
    
Loop


Application.ScreenUpdating = True


End Sub

 

[tsonko]

And the code below will be much quicker than the one above depending on the size of your table.

Sub numberCrossed1()


Dim rng As Range, rng1 As Range, i As Long, m As Long
Dim arr() As Double
Dim ll As Range, ul As Range


Set rng = Worksheets("Sheet3").Range("A2")
Set rng1 = Worksheets("Sheet3").Range("D2")
Set ll = Worksheets("Sheet3").Range("H1")
Set ul = Worksheets("Sheet3").Range("H2")


i = 0
m = 0


ReDim arr(1, 0)


Do While rng.Offset(i) <> Empty


    If rng.Offset(i) >= ll And rng.Offset(i) <= ul Then
    
        ReDim Preserve arr(1, UBound(arr, 2) + m)


        arr(0, UBound(arr, 2)) = rng.Offset(i, 0)
        arr(1, UBound(arr, 2)) = rng.Offset(i, 1)
        
        m = m + 1
        
    End If


    i = i + 1


Loop


Range(rng1, rng1.Offset(UBound(arr, 2), 1)) = Application.WorksheetFunction.Transpose(arr)




End Sub