excelvbazerocrossing

Excel macro to identify 0 crossing of the value

I have Frequency value in column A and corresponding Gain value in column B, Phase value in column C. Frequency ranges from 10 to 1e06 whereas gain varies from 100 to -100 and phase varies from 180 to -180. In cell D1 I want value of frequency (fc) where gain crosses 0 and in cell D2 I want phase value at fc. I used macro shared in Run brute force on a column to identify if the values cross over a point using VBA. But I am not able to access the value of frequency where gain cross 0. I need help in writing code to access that value at particular cell.

This is the macro I am using to detect zero crossing.

Sub Tester()
    Dim sht As Worksheet, lastRow As Long, xvals, yvals, r As Long
    Dim th As Double, y1, y2, x1, x2


    Set sht = ActiveSheet
    lastRow = sht.Range("B" & Rows.Count).End(xlUp).Row

    'assumes y vals in "B" and x vals in "A"
    'adjust as rtequired...
    yvals = sht.Range(sht.Cells(14, "B"), sht.Cells(lastRow, "B"))
    xvals = sht.Range(sht.Cells(14, "A"), sht.Cells(lastRow, "A"))

    th = 0

    For r = 1 To UBound(yvals) - 1
        y1 = yvals(r, 1)
        y2 = yvals(r + 1, 1)

        'pair of points crosses the threshold?
        If IsNumeric(y1) And IsNumeric(y2) Then
            If (y1 < th And y2 > th) Or (y1 > th And y2 < th) Then
                x1 = xvals(r, 1)
                x2 = xvals(r + 1, 1)
                '*************
                'calculate the intercept
                '*************
            End If
        End If
    Next r
End Sub

Sample Data

Here is the sample data

Solution

  • I wish you had posted a sample of the data to see how the data is changing. Perhaps a logarithmic scale is more appropriate for the frequency.
    If you are looking for one zero point, update your code as below.

    Sub Tester()
    Dim sht As Worksheet, lastRow As Long, xvals, yvals, r As Long
    Dim th As Double, y1, y2, x1, x2
    Dim zvals, z1, z2, z0, x0     ' added

    Set sht = ActiveSheet
    lastRow = sht.Range("B" & Rows.Count).End(xlUp).Row

    'assumes y vals in "B" and x vals in "A"
    'adjust as rtequired...
    yvals = sht.Range(sht.Cells(14, "B"), sht.Cells(lastRow, "B"))
    xvals = sht.Range(sht.Cells(14, "A"), sht.Cells(lastRow, "A"))
    zvals = sht.Range("C14:C" & lastRow).Value    ' added

    th = 0

    For r = 1 To UBound(yvals) - 1
        y1 = yvals(r, 1)
        y2 = yvals(r + 1, 1)

        'pair of points crosses the threshold?
        If IsNumeric(y1) And IsNumeric(y2) Then
            If (y1 < th And y2 > th) Or (y1 > th And y2 < th) Then
                x1 = xvals(r, 1)
                x2 = xvals(r + 1, 1)
                z1 = zvals(r, 1)      ' added
                z2 = zvals(r + 1, 1)  ' added
                '*************
                'calculate the intercept
                '*************
                x0 = (x2 * y1 - x1 * y2 + th * (x1 - x2)) / (y1 - y2)  ' added
                z0 = (x2 * z1 - x1 * z2 + x0 * (z2 - z1)) / (x2 - x1)  ' added
                sht.Range("D1").Value = x0           ' added
                sht.Range("D2").Value = z0           ' added
                Exit For                 ' added
            End If
        End If
    Next r
End Sub