VBAで2点間の距離が指定以内のものを抽出

こちらのポストで出題されたやつVBAで書いてみた

最近良さげな課題があったので #Excelクイズ として出題してみます。

【入力】
・ID（重複のない連番）
・X座標（数値）
・Y座標（数値）
で構成された表データ

【目的】
2点間の距離が「3」未満になるIDの組み合わせを抽出したい。

【出力】
・組み合わせの片方の ID X座標 Y座標
・もう片方の ID… pic.twitter.com/gIQrTHlLEX

— ちゅん🐤 (@KotorinChunChun) February 15, 2024

100万件で解いてみた、距離も100より小さいものに変更
俺の環境だと4秒くらいで出力された

Option Explicit

Private Sub CopyToClipboard(strText As String)
    Dim objData As New DataObject
    objData.SetText strText
    objData.PutInClipboard
End Sub

Private Sub Main()

    Dim wf As WorksheetFunction
    Set wf = WorksheetFunction
    
    Dim arr
    Let arr = wf.Sort(Range("a3").Resize(1000000, 3).Value, 2)
    
    Range("E3").Resize(1000000, 7).Clear
    
    Dim list
    Set list = CreateObject("System.Collections.ArrayList")
    
    Dim i, j
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = i To UBound(arr, 1)
        
            If i <> j Then
                
                Dim id1: id1 = arr(i, 1)
                Dim x1: x1 = arr(i, 2)
                Dim y1: y1 = arr(i, 3)
                Dim id2: id2 = arr(j, 1)
                Dim x2: x2 = arr(j, 2)
                Dim y2: y2 = arr(j, 3)
                
                If x2 - x1 > 3 Then Exit For '' これ以上は明らかに無駄やし打ち切る
                
                Dim dist: dist = ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) ^ 0.5
                
                If dist < 100 Then
                    list.Add Join(Array(id1, x1, y1, id2, x2, y2, dist), vbTab)
                End If
            
            End If
        Next
    Next
    
    CopyToClipboard Join(list.ToArray, vbLf)
    Range("E3").PasteSpecial
    
End Sub

Private Sub Entry()
    Dim t: t = Timer
    Call Main
    Debug.Print Timer - t
End Sub