Option Explicit
 
Public Sub ユークリッド距離順()
    Const BA1 As Long = 1000    '表縦の倍率
    Const BA2 As Long = 100     '表横の倍率
    Const BA3 As Long = 10      '表高の倍率
    Const BA4 As Long = 1000    '裏縦の倍率
    Const BA5 As Long = 100     '裏横の倍率
    Const BA6 As Long = 10      '裏高の倍率
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim dicT As Object
    Dim maxrow1 As Long
    Dim namerow As Long
    Dim wrow As Long
    Dim row2 As Long
    Dim name As String
 
    Dim d1 As Long, d2 As Long, d11 As Long, d12 As Long, d13 As Long, d21 As Long, d22 As Long, d23 As Long
    Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    maxrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row    'sheet1 最終行を求める
    If maxrow1 < 4 Then Exit Sub
    name = sh2.Range("B1").Value
    If name = "" Then Exit Sub
    sh2.Rows("5:" & Rows.Count).ClearContents       '5行目以降クリア
    namerow = 0
    For wrow = 3 To maxrow1
        If name = sh1.Cells(wrow, 1).Value Then
            namerow = wrow
        End If
    Next
    If namerow = 0 Then
        MsgBox (name & "が存在しません")
        Exit Sub
    End If
    'ユークリッド距離の計算
    row2 = 5
    For wrow = 3 To maxrow1
        If wrow <> namerow Then
            sh2.Cells(row2, 1).Value = sh1.Cells(wrow, 1).Value '表名前
            sh2.Cells(row2, 4).Value = sh1.Cells(wrow, 1).Value '裏名前
            d11 = (sh1.Cells(wrow, 2).Value - sh1.Cells(namerow, 2).Value)
            d12 = (sh1.Cells(wrow, 3).Value - sh1.Cells(namerow, 3).Value)
            d13 = (sh1.Cells(wrow, 4).Value - sh1.Cells(namerow, 4).Value)
            d21 = (sh1.Cells(wrow, 5).Value - sh1.Cells(namerow, 5).Value)
            d22 = (sh1.Cells(wrow, 6).Value - sh1.Cells(namerow, 6).Value)
            d23 = (sh1.Cells(wrow, 7).Value - sh1.Cells(namerow, 7).Value)
            d1 = d11 * d11 * BA1 + d12 * d12 * BA2 + d13 * d13 * BA3
            d2 = d21 * d21 * BA4 + d22 * d22 * BA5 + d23 * d23 * BA6
            sh2.Cells(row2, 2).Value = d1   '表距離
            sh2.Cells(row2, 5).Value = d2   '裏距離
            row2 = row2 + 1
        End If
    Next
    'ソート
    sh2.Range("A5:B" & row2 - 1).Sort key1:=sh2.Range("B5"), Order1:=xlAscending, Header:=xlNo
    sh2.Range("D5:E" & row2 - 1).Sort key1:=sh2.Range("E5"), Order1:=xlAscending, Header:=xlNo
    sh2.Rows("10:" & Rows.Count).ClearContents       '10行目以降クリア
    MsgBox ("完了")
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOODpuODvOOCr+ODquODg+ODiei3nemboumghigpCiAgICBDb25zdCBCQTEgQXMgTG9uZyA9IDEwMDAgICAgJ+ihqOe4puOBruWAjeeOhwogICAgQ29uc3QgQkEyIEFzIExvbmcgPSAxMDAgICAgICfooajmqKrjga7lgI3njocKICAgIENvbnN0IEJBMyBBcyBMb25nID0gMTAgICAgICAn6KGo6auY44Gu5YCN546HCiAgICBDb25zdCBCQTQgQXMgTG9uZyA9IDEwMDAgICAgJ+ijj+e4puOBruWAjeeOhwogICAgQ29uc3QgQkE1IEFzIExvbmcgPSAxMDAgICAgICfoo4/mqKrjga7lgI3njocKICAgIENvbnN0IEJBNiBBcyBMb25nID0gMTAgICAgICAn6KOP6auY44Gu5YCN546HCiAgICBEaW0gc2gxIEFzIFdvcmtzaGVldAogICAgRGltIHNoMiBBcyBXb3Jrc2hlZXQKICAgIERpbSBkaWNUIEFzIE9iamVjdAogICAgRGltIG1heHJvdzEgQXMgTG9uZwogICAgRGltIG5hbWVyb3cgQXMgTG9uZwogICAgRGltIHdyb3cgQXMgTG9uZwogICAgRGltIHJvdzIgQXMgTG9uZwogICAgRGltIG5hbWUgQXMgU3RyaW5nCgogICAgRGltIGQxIEFzIExvbmcsIGQyIEFzIExvbmcsIGQxMSBBcyBMb25nLCBkMTIgQXMgTG9uZywgZDEzIEFzIExvbmcsIGQyMSBBcyBMb25nLCBkMjIgQXMgTG9uZywgZDIzIEFzIExvbmcKICAgIFNldCBkaWNUID0gQ3JlYXRlT2JqZWN0KCJTY3JpcHRpbmcuRGljdGlvbmFyeSIpICAgICcg6YCj5oOz6YWN5YiX44Gu5a6a576pCiAgICBTZXQgc2gxID0gV29ya3NoZWV0cygiU2hlZXQxIikKICAgIFNldCBzaDIgPSBXb3Jrc2hlZXRzKCJTaGVldDIiKQogICAgbWF4cm93MSA9IHNoMS5DZWxscyhSb3dzLkNvdW50LCAxKS5FbmQoeGxVcCkuUm93ICAgICdzaGVldDEg5pyA57WC6KGM44KS5rGC44KB44KLCiAgICBJZiBtYXhyb3cxIDwgNCBUaGVuIEV4aXQgU3ViCiAgICBuYW1lID0gc2gyLlJhbmdlKCJCMSIpLlZhbHVlCiAgICBJZiBuYW1lID0gIiIgVGhlbiBFeGl0IFN1YgogICAgc2gyLlJvd3MoIjU6IiAmIFJvd3MuQ291bnQpLkNsZWFyQ29udGVudHMgICAgICAgJzXooYznm67ku6XpmY3jgq/jg6rjgqIKICAgIG5hbWVyb3cgPSAwCiAgICBGb3Igd3JvdyA9IDMgVG8gbWF4cm93MQogICAgICAgIElmIG5hbWUgPSBzaDEuQ2VsbHMod3JvdywgMSkuVmFsdWUgVGhlbgogICAgICAgICAgICBuYW1lcm93ID0gd3JvdwogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgSWYgbmFtZXJvdyA9IDAgVGhlbgogICAgICAgIE1zZ0JveCAobmFtZSAmICLjgYzlrZjlnKjjgZfjgb7jgZvjgpMiKQogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgICfjg6bjg7zjgq/jg6rjg4Pjg4not53pm6Ljga7oqIjnrpcKICAgIHJvdzIgPSA1CiAgICBGb3Igd3JvdyA9IDMgVG8gbWF4cm93MQogICAgICAgIElmIHdyb3cgPD4gbmFtZXJvdyBUaGVuCiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyLCAxKS5WYWx1ZSA9IHNoMS5DZWxscyh3cm93LCAxKS5WYWx1ZSAn6KGo5ZCN5YmNCiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyLCA0KS5WYWx1ZSA9IHNoMS5DZWxscyh3cm93LCAxKS5WYWx1ZSAn6KOP5ZCN5YmNCiAgICAgICAgICAgIGQxMSA9IChzaDEuQ2VsbHMod3JvdywgMikuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgMikuVmFsdWUpCiAgICAgICAgICAgIGQxMiA9IChzaDEuQ2VsbHMod3JvdywgMykuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgMykuVmFsdWUpCiAgICAgICAgICAgIGQxMyA9IChzaDEuQ2VsbHMod3JvdywgNCkuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgNCkuVmFsdWUpCiAgICAgICAgICAgIGQyMSA9IChzaDEuQ2VsbHMod3JvdywgNSkuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgNSkuVmFsdWUpCiAgICAgICAgICAgIGQyMiA9IChzaDEuQ2VsbHMod3JvdywgNikuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgNikuVmFsdWUpCiAgICAgICAgICAgIGQyMyA9IChzaDEuQ2VsbHMod3JvdywgNykuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgNykuVmFsdWUpCiAgICAgICAgICAgIGQxID0gZDExICogZDExICogQkExICsgZDEyICogZDEyICogQkEyICsgZDEzICogZDEzICogQkEzCiAgICAgICAgICAgIGQyID0gZDIxICogZDIxICogQkE0ICsgZDIyICogZDIyICogQkE1ICsgZDIzICogZDIzICogQkE2CiAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyLCAyKS5WYWx1ZSA9IGQxICAgJ+ihqOi3nembogogICAgICAgICAgICBzaDIuQ2VsbHMocm93MiwgNSkuVmFsdWUgPSBkMiAgICfoo4/ot53pm6IKICAgICAgICAgICAgcm93MiA9IHJvdzIgKyAxCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICAn44K944O844OICiAgICBzaDIuUmFuZ2UoIkE1OkIiICYgcm93MiAtIDEpLlNvcnQga2V5MTo9c2gyLlJhbmdlKCJCNSIpLCBPcmRlcjE6PXhsQXNjZW5kaW5nLCBIZWFkZXI6PXhsTm8KICAgIHNoMi5SYW5nZSgiRDU6RSIgJiByb3cyIC0gMSkuU29ydCBrZXkxOj1zaDIuUmFuZ2UoIkU1IiksIE9yZGVyMTo9eGxBc2NlbmRpbmcsIEhlYWRlcjo9eGxObwogICAgc2gyLlJvd3MoIjEwOiIgJiBSb3dzLkNvdW50KS5DbGVhckNvbnRlbnRzICAgICAgICcxMOihjOebruS7pemZjeOCr+ODquOCogogICAgTXNnQm94ICgi5a6M5LqGIikKRW5kIFN1Ygo=