Public Function geo_line_complex_intersect(xy_line_1 As Variant, xy_line_2 As Variant, Optional compact_results As Boolean = True) As Variant
'function to return all XY intersections between two defined continuous lines or broken lines
'leave blank rows or #NA between line coordinates to use individual unconnected lines as inputs
'create array from input data
xy_line_1 = array_convert_rng_to_array(xy_line_1)
xy_line_2 = array_convert_rng_to_array(xy_line_2)
On Error GoTo 0
Dim line_1_count As Long
Dim line_2_count As Long
Dim i As Long
Dim count_x As Long
Dim count_y As Long
Dim x1_line_1 As Double
Dim x2_line_1 As Double
Dim x1_line_2 As Double
Dim x2_line_2 As Double
Dim y1_line_1 As Double
Dim y2_line_1 As Double
Dim y1_line_2 As Double
Dim y2_line_2 As Double
Dim xy_intersection(1 To 1, 1 To 2) As Variant
Dim xy_intersection_results As Variant
Dim x_intersection As Double
Dim y_intersection As Double
Dim line_1_segment(1 To 2, 1 To 2)
Dim line_2_segment(1 To 2, 1 To 2)
Dim temp
'replace any #NA errors with equivalent of 'Empty'/vbNullString
xy_line_1 = array_replace_errors(xy_line_1)
xy_line_2 = array_replace_errors(xy_line_2)
'loop through first line line segments and check for intersections with all segments of second line
For line_1_count = 1 To UBound(xy_line_1) - 1
'create line 1 segment array
line_1_segment(1, 1) = xy_line_1(line_1_count, 1)
line_1_segment(2, 1) = xy_line_1(line_1_count + 1, 1)
line_1_segment(1, 2) = xy_line_1(line_1_count, 2)
line_1_segment(2, 2) = xy_line_1(line_1_count + 1, 2)
'check if line 1 segment includes blank/empty coordinate rows, and skip processing this line segment
If array_value_in_array(vbNullString, line_1_segment) Then GoTo skip_line_1
For line_2_count = 1 To UBound(xy_line_2) - 1
'create line 2 segment array
line_2_segment(1, 1) = xy_line_2(line_2_count, 1)
line_2_segment(2, 1) = xy_line_2(line_2_count + 1, 1)
line_2_segment(1, 2) = xy_line_2(line_2_count, 2)
line_2_segment(2, 2) = xy_line_2(line_2_count + 1, 2)
'check if line 2 segment includes blank/empty coordinate rows, and skip processing this line segment
If array_value_in_array(vbNullString, line_2_segment) Then GoTo skip_line_2
'check and determine intersection point coordinates
temp = geo_line_intersect(line_1_segment, line_2_segment)
'create intersection coordinates results array
If i = 0 Then
'first intersection
xy_intersection(1, 1) = temp(0)
xy_intersection(1, 2) = temp(1)
xy_intersection_results = xy_intersection
i = 1
Else
'subsequent intersections
xy_intersection(1, 1) = temp(0)
xy_intersection(1, 2) = temp(1)
xy_intersection_results = CombineArrays(xy_intersection_results, xy_intersection)
End If
skip_line_2:
Next line_2_count
skip_line_1:
Next line_1_count
'compact results removing any #NA rows/results
If compact_results Then
xy_intersection_results = array_remove_error_rows(xy_intersection_results)
End If
'return results
geo_line_complex_intersect = xy_intersection_results
End Function
Public Function geo_line_intersect(xy_line_1 As Variant, xy_line_2 As Variant) As Variant
'test to determine if two lines intersect based on XY coordinates, returns XY coordinate of intersection point if
'line segments cross each other. Otherwise returns NA errors
'Refer [URL unfurl="true"]https://en.wikipedia.org/wiki/Line-line_intersection[/URL]
'create array from input data
xy_line_1 = array_convert_rng_to_array(xy_line_1)
xy_line_2 = array_convert_rng_to_array(xy_line_2)
'setup variables for individual points
Dim x1_line_1 As Double
Dim x2_line_1 As Double
Dim x1_line_2 As Double
Dim x2_line_2 As Double
Dim y1_line_1 As Double
Dim y2_line_1 As Double
Dim y1_line_2 As Double
Dim y2_line_2 As Double
Dim x_intersection As Double
Dim y_intersection As Double
Dim t As Double
Dim u As Double
Dim denominator As Double
'read individual points coords
x1_line_1 = xy_line_1(1, 1)
x2_line_1 = xy_line_1(2, 1)
x1_line_2 = xy_line_2(1, 1)
x2_line_2 = xy_line_2(2, 1)
y1_line_1 = xy_line_1(1, 2)
y2_line_1 = xy_line_1(2, 2)
y1_line_2 = xy_line_2(1, 2)
y2_line_2 = xy_line_2(2, 2)
'denominator, if denominator is zero then lines are parallel
denominator = (x1_line_1 - x2_line_1) * (y1_line_2 - y2_line_2) - (y1_line_1 - y2_line_1) * (x1_line_2 - x2_line_2)
If denominator <> 0 Then
'lines are not parallel
t = ((x1_line_1 - x1_line_2) * (y1_line_2 - y2_line_2) - (y1_line_1 - y1_line_2) * (x1_line_2 - x2_line_2)) / denominator
u = -((x1_line_1 - x2_line_1) * (y1_line_1 - y1_line_2) - (y1_line_1 - y2_line_1) * (x1_line_1 - x1_line_2)) / denominator
Else
'line segments are parallel
geo_line_intersect = Array(CVErr(xlErrNA), CVErr(xlErrNA))
Exit Function
End If
'check if lines intersect
If u >= 0 And u <= 1 And t >= 0 And t <= 1 Then
'line segments do intersect
'intersection point coordinates
x_intersection = x1_line_1 + t * (x2_line_1 - x1_line_1)
y_intersection = y1_line_1 + t * (y2_line_1 - y1_line_1)
geo_line_intersect = Array(x_intersection, y_intersection)
Else
'line segments do not intersect
geo_line_intersect = Array(CVErr(xlErrNA), CVErr(xlErrNA))
End If
End Function
Public Function array_remove_error_rows(arr As Variant) As Variant
'Function to remove rows that contain an error in array
arr = array_convert_rng_to_array(arr)
Dim temp_arr As Variant
Dim valid_count As Long
Dim row_count As Long
Dim row1 As Long
Dim row2 As Long
Dim col_count As Long
Dim col_loop As Long
Dim col1 As Long
Dim col2 As Long
'establish array limits for 1st and 2nd dimensions
row1 = LBound(arr, 1)
row2 = UBound(arr, 1)
col1 = LBound(arr, 2)
col2 = UBound(arr, 2)
'determine number of valid points and write to array removing #NA results
valid_count = LBound(arr, 1) - 1
For row_count = row1 To row2
For col_count = col1 To col2
If IsError(arr(row_count, col_count)) Then
GoTo skip_row
End If
'at end of row (at last column) execute following if there were no errors in the row of data and
're-write entire row values to new row position
If col_count = col2 Then 'last column
valid_count = valid_count + 1
'loop through all columns at current row and populate values to new position
For col_loop = col1 To col2
arr(valid_count, col_loop) = arr(row_count, col_loop)
Next col_loop
End If
Next col_count
skip_row:
Next row_count
'resize results array to remove trailing #NA results
temp_arr = arr
ReDim arr(row1 To valid_count, col1 To col2)
For row_count = row1 To valid_count
For col_count = col1 To col2
arr(row_count, col_count) = temp_arr(row_count, col_count)
Next col_count
Next row_count
'return results
array_remove_error_rows = arr
End Function
Public Function array_value_in_array(value_to_be_found As Variant, arr As Variant) As Boolean
'Function to check if a value is in an array of values
Dim element As Variant
On Error GoTo error_handling:
For Each element In arr
If element = value_to_be_found Then
array_value_in_array = True
Exit Function
End If
Next element
Exit Function
error_handling:
On Error GoTo 0
array_value_in_array = False
End Function
Function array_convert_rng_to_array(arr As Variant)
'function to convert ranges to arrays
Dim temp As Variant
'if already an array exit function returning same array
If IsArray(arr) Then
array_convert_rng_to_array = arr
Exit Function
End If
'convert range input into array
If arr.Columns.Count = 1 And arr.Rows.Count = 1 Then
temp = arr.Value2
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = temp
array_convert_rng_to_array = arr
Else
array_convert_rng_to_array = arr.Value2
End If
End Function
Public Function array_replace_errors(arr As Variant) As Variant
'Function to replace all array values that are errors with 'Empty'/check if a value is in an array of values
arr = array_convert_rng_to_array(arr)
Dim row_count As Long
Dim col_count As Long
'loop through all elements in array and replace any errors with 'Empty'/vbNullString
For row_count = LBound(arr, 1) To UBound(arr, 1)
For col_count = LBound(arr, 2) To UBound(arr, 2)
If IsError(arr(row_count, col_count)) Then arr(row_count, col_count) = vbNullString
Next col_count
Next row_count
'return results
array_replace_errors = arr
End Function
Function CombineArrays(a As Variant, b As Variant, Optional stacked As Boolean = True) As Variant
'assumes that A and B are 2-dimensional variant arrays
'if stacked is true then A is placed on top of B
'in this case the number of rows must be the same,
'otherwise they are placed side by side A|B
'in which case the number of columns are the same
'LBound can be anything but is assumed to be
'the same for A and B (in both dimensions)
'False is returned if a clash
Dim lb As Long, m_A As Long, n_A As Long
Dim m_B As Long, n_B As Long
Dim m As Long, n As Long
Dim i As Long, j As Long, k As Long
Dim c As Variant
If TypeName(a) = "Range" Then a = a.Value
If TypeName(b) = "Range" Then b = b.Value
lb = LBound(a, 1)
m_A = UBound(a, 1)
n_A = UBound(a, 2)
m_B = UBound(b, 1)
n_B = UBound(b, 2)
If stacked Then
m = m_A + m_B + 1 - lb
n = n_A
If n_B <> n Then
CombineArrays = False
Exit Function
End If
Else
m = m_A
If m_B <> m Then
CombineArrays = False
Exit Function
End If
n = n_A + n_B + 1 - lb
End If
ReDim c(lb To m, lb To n)
For i = lb To m
For j = lb To n
If stacked Then
If i <= m_A Then
c(i, j) = a(i, j)
Else
c(i, j) = b(lb + i - m_A - 1, j)
End If
Else
If j <= n_A Then
c(i, j) = a(i, j)
Else
c(i, j) = b(i, lb + j - n_A - 1)
End If
End If
Next j
Next i
CombineArrays = c
End Function
)/(b)))^(2 ((b)/(r)))=1