Jeffrey040
New Member
- Joined
- May 17, 2009
- Messages
- 11
I have a graph with two intersecting lines. Is there any way to extract the value where the two lines cross.
Thanks
Thanks
Sub test()
Dim aVal As Variant, bVal As Variant, xVal As Variant
Dim Intersections As Variant
With ActiveSheet
With .ChartObjects.Item(1).Chart
aVal = .SeriesCollection(1).Values
bVal = .SeriesCollection(2).Values
xVal = .SeriesCollection(1).XValues
End With
End With
Intersections = ArraysIntersect(aVal, bVal, xVal)
With Range("E2")
.Resize(UBound(aVal), 2).ClearContents
.Resize(UBound(Intersections, 1), 2).Value = Intersections
End With
End Sub
Function ArraysIntersect(aArray As Variant, bArray As Variant, xArray As Variant) As Variant
Rem given xValues, Y1Values and y2Values, returns their intersections (linear interpolation)
Rem returns an array _
(n,1) xVal of intersept _
(n,2) yVal (y1 = y2) of intesect, _
(n,3) index before intersection _
(n,4) index after intersection
Dim Low As Long, High As Long
Dim i As Long, Pointer As Long
Dim Result As Variant
Dim An0 As Double, Bn0 As Double, An1 As Double, Bn1 As Double
Dim interval As Double, aSlope As Double, bSlope As Double, t As Double
Dim matchVal As Double, matchX As Double, preIndex As Long, postIndex As Long
Low = LBound(aArray): High = UBound(aArray)
Pointer = 0
ReDim Result(1 To 4, 1 To (High - Low) + 1)
Rem function returns transpose of Result
If aArray(1) = bArray(1) Then
matchVal = aArray(1)
matchX = xArray(1)
preIndex = 1: postIndex = 1
GoSub addOne
End If
For i = Low To High - 1
An0 = aArray(i): An1 = aArray(i + 1)
Bn0 = bArray(i): Bn1 = bArray(i + 1)
If An1 = Bn1 Then
Rem got one
matchVal = An1
matchX = xArray(i + 1)
preIndex = i + 1: postIndex = i + 1
GoSub addOne
Else
If ((An0 < Bn0) Xor (An1 < Bn1)) Then
Rem crossed
interval = xArray(i + 1) - xArray(i)
aSlope = (An1 - An0) / interval
bSlope = (Bn1 - Bn0) / interval
Rem since bn0 + bslope*t = an0 + aslope*t
t = (An0 - Bn0) / (bSlope - aSlope)
matchVal = An0 + (aSlope * t)
matchX = xArray(i) + (interval * t)
preIndex = i: postIndex = i + 1
GoSub addOne
End If
End If
Next i
If Pointer <> 0 Then
ReDim Preserve Result(1 To 4, 1 To Pointer)
Else
ReDim Result(1 To 4, 1 To 1)
End If
If UBound(Result, 2) = 1 Then
ReDim Result(1 To 1, 1 To 4)
Result(1, 1) = matchX
Result(1, 2) = matchVal
Result(1, 3) = preIndex
Result(1, 4) = postIndex
Else
Result = Application.Transpose(Result)
End If
ArraysIntersect = Result
Exit Function
addOne:
Pointer = Pointer + 1
Result(1, Pointer) = matchX
Result(2, Pointer) = matchVal
Result(3, Pointer) = preIndex
Result(4, Pointer) = postIndex
Return
End Function