Các bạn sửa giúp mình đoạn code này với:
trước code được viết với công thức chạy :
S2= Căn bậc 2(( a 2 - a 1 )^2 + (b 2 - b 1 )^2)
S3= Căn bậc 2(( a 3 - a 1 )^2 + (b 3 - b 1 )^2)
S4= Căn bậc 2(( a 4 - a 1 )^2 + (b 4 - b 1 )^2)
Các bạn sửa giúp tớ thành công thức :
S2= Căn bậc 2(( a 2 - a 1 )^2 + (b 2 - b 1 )^2 + (C 2 - C1)^2)
S3= Căn bậc 2(( a 3 - a 1 )^2 + (b 3 - b 1 )^2 + (C 3 - C1)^2)
S4= Căn bậc 2(( a 4 - a 1 )^2 + (b 4 - b 1 )^2 + (C 4 - C1)^2)
Còn các cách chạy, lặp xóa ... vẫn giữ nguyên như code cũ nhé.
Sub DoSomething()
Dim Arr, tmp, index, result, count As Long, k As Long, e As Double, r As Long, c As Long, s As Double, startCell As Range
Arr = Range("$A$13:$E$25012").Value
e = [B1]
Set startCell = Range("G13")
ReDim index(1 To 1)
ReDim result(1 To UBound(Arr, 2), 1 To 1)
k = 0
Do
k = k + 1
ReDim Preserve result(1 To UBound(Arr, 2), 1 To k)
For r = 1 To UBound(Arr, 2)
result(r, k) = Arr(1, r)
Next r
count = 0
For r = 2 To UBound(Arr)
s = Sqr((Arr(1, 2) - Arr(r, 2)) ^ 2 + (Arr(1, 3) - Arr(r, 3)) ^ 2)
If s >= e Then
count = count + 1
ReDim Preserve index(1 To count)
index(count) = r
End If
Next r
If count > 0 Then
ReDim tmp(1 To count, 1 To UBound(Arr, 2))
For r = 1 To count
For c = 1 To UBound(Arr, 2)
tmp(r, c) = Arr(index(r), c)
Next c
Next r
Arr = tmp
End If
Loop Until count = 0
ReDim Arr(1 To k, 1 To UBound(result))
For r = 1 To k
For c = 1 To UBound(Arr, 2)
Arr(r, c) = result(c, r)
Next c
Next r
startCell.Resize(k, UBound(Arr, 2)).Value = Arr
End Sub
