×
INTELLIGENT WORK FORUMS
FOR ENGINEERING PROFESSIONALS

Are you an
Engineering professional?
Join Eng-Tips Forums!
• Talk With Other Members
• Be Notified Of Responses
• Keyword Search
Favorite Forums
• Automated Signatures
• Best Of All, It's Free!

*Eng-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

#### Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

# Help modifying a VBA Code

## Help modifying a VBA Code

(OP)
The code below calculates the minimal distance in space of between two lines.
Points of line 1 have their coordinates x,y,z in columns c,d,b and those of line 2 in columns r,s,q. The minimal value is displayed in a message.
I want to change the macro so that each minimal distance for each point on line 1 is calculated and displayed in adjacent cells in column e. I tried to modify the macro by adding a loop calculation but failed miserably. Can somebody help?
Thanks

Sub find_closest_distance()

With Worksheets("sheet1")
x1 = "c": y1 = "d": z1 = "b"
firstrow1 = 5
lastrow1 = .Cells(.Rows.Count, x1).End(xlUp).Row
x2 = "r": y2 = "s": z2 = "q"
firstrow2 = 5
lastrow2 = .Cells(.Rows.Count, x2).End(xlUp).Row

ning = .Cells(8, "x")
eing = .Cells(9, "x")
Eion = .Cells(7, "x")

min_distance = 1E+300
For i = firstrow1 To lastrow1
x1_acc = .Cells(i, x1): y1_acc = .Cells(i, y1): z1_acc = .Cells(i, z1):
For j = firstrow2 To lastrow2
x2_acc = ning + .Cells(j, x2): y2_acc = eing + .Cells(j, y2): z2_acc = Eion + .Cells(j, z2)

dist1 = (x1_acc - x2_acc) ^ 2 + (y1_acc - y2_acc) ^ 2 + (z1_acc - z2_acc) ^ 2
If dist1 < min_distance Then
min_distance = dist1
min_i = i: min_j = j
min_x1_acc = x1_acc: min_y1_acc = y1_acc: min_z1 = z1_acc
min_x2_acc = x2_acc: min_y2_acc = y2_acc: min_z2 = z2_acc
End If
Next j
Next i

MsgBox "Then miniumum distance is " & Sqr(min_distance) & " from point (Z = " & min_z1 & ", X = " & min_x1_acc & ", Y = " & min_y1_acc & ") to point (Z = " & min_z2 - Eion & ", X = " & min_x2_acc - ning & ", Y = " & min_y2_acc - eing & ")"

End With
End Sub

### RE: Help modifying a VBA Code

Ammended code to write minimum distance for each row to column E, point on Line 2 to Column F and overall minimum and points to cells E#, G3, and I3:

#### CODE -->

min_distance = 1E+300
For i = firstrow1 To lastrow1
min_distance_i = 1E+300
x1_acc = .Cells(i, x1): y1_acc = .Cells(i, y1): z1_acc = .Cells(i, z1):
For j = firstrow2 To lastrow2
x2_acc = ning + .Cells(j, x2): y2_acc = eing + .Cells(j, y2): z2_acc = Eion + .Cells(j, z2)

dist1 = (x1_acc - x2_acc) ^ 2 + (y1_acc - y2_acc) ^ 2 + (z1_acc - z2_acc) ^ 2
If dist1 < min_distance_i Then
min_distance_i = dist1
min_j_i = j

End If
Next j

.Cells(i, "e") = Sqr(min_distance_i)
.Cells(i, "f") = min_j_i

If min_distance_i < min_distance Then
min_distance = min_distance_i
min_i = i: min_j = min_j_i

End If
Next i

.Cells(3, "e") = Sqr(min_distance)
.Cells(3, "g") = min_i
.Cells(3, "i") = min_j

End With
End Sub 

Doug Jenkins
Interactive Design Services
http://newtonexcelbach.wordpress.com/

### RE: Help modifying a VBA Code

(OP)
Thank you very much IDS, it worked. For future references for the guys who do not know VBA the array formula is:
MIN((($B$5:$B$500-Q5-$X$7)^2+($C$5:$C$500-R5-$X$8)^2+($D$5:$D$500-S5-$X$9)^2)^0.5)
thanks again IDS

### RE: Help modifying a VBA Code

(OP)
acknowledged

#### Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

#### Red Flag Submitted

Thank you for helping keep Eng-Tips Forums free from inappropriate posts.
The Eng-Tips staff will check this out and take appropriate action.

Close Box

# Join Eng-Tips® Today!

Join your peers on the Internet's largest technical engineering professional community.
It's easy to join and it's free.

Here's Why Members Love Eng-Tips Forums:

• Talk To Other Members
• Notification Of Responses To Questions
• Favorite Forums One Click Access
• Keyword Search Of All Posts, And More...

Register now while it's still free!