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    '最大行が4未満なら終了
    name = sh2.Range("B1").Value    'B1の内容をnameへ設定
    If name = "" Then Exit Sub      'nameが空白なら終了（B1が空白なら終了）
    sh2.Rows("5:" & Rows.Count).ClearContents       '5行目以降クリア
    namerow = 0                     '名前行をクリア
    '3行から最終行まで繰り返す（元データシート）
    For wrow = 3 To maxrow1
        '検索用の名前と一致した場合、その行を名前行に記憶する
        If name = sh1.Cells(wrow, 1).Value Then
            namerow = wrow
        End If
    Next
    '名前行に行番号が設定されていないなら、終了する
    If namerow = 0 Then
        MsgBox (name & "が存在しません")    '「XXXが存在しません」の文字を画面に表示する
        Exit Sub
    End If
    'ユークリッド距離の計算
    row2 = 5    '結果表示用シートの5行目から出力する
    '3行から最終行まで繰り返す（元データシート）
    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        '表の縦の差^2*倍率＋表の横の差^2*倍率＋表の高さの差^2*倍率
            d2 = d21 * d21 * BA4 + d22 * d22 * BA5 + d23 * d23 * BA6        '裏の縦の差^2*倍率＋裏の横の差^2*倍率＋裏の高さの差^2*倍率
            sh2.Cells(row2, 2).Value = d1   '表の距離
            sh2.Cells(row2, 5).Value = d2   '裏の距離
            row2 = row2 + 1 '結果表示用シートの行番号に1加算
        End If
    Next
    'ソート
    sh2.Range("A5:B" & row2 - 1).Sort key1:=sh2.Range("B5"), Order1:=xlAscending, Header:=xlNo  '表のソート　ソート範囲A5:Bの最終行
    sh2.Range("D5:E" & row2 - 1).Sort key1:=sh2.Range("E5"), Order1:=xlAscending, Header:=xlNo  '裏のソート　ソート範囲D5:Eの最終行
    sh2.Rows("10:" & Rows.Count).ClearContents       '10行目以降クリア（5件迄表示なので10行目以降は不要）
    MsgBox ("完了")     '「完了」の文字を画面に表示する
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIOODpuODvOOCr+ODquODg+ODiei3nemboumghigpCiAgICBDb25zdCBCQTEgQXMgTG9uZyA9IDEwMDAgICAgJ+ihqOe4puOBruWAjeeOhwogICAgQ29uc3QgQkEyIEFzIExvbmcgPSAxMDAgICAgICfooajmqKrjga7lgI3njocKICAgIENvbnN0IEJBMyBBcyBMb25nID0gMTAgICAgICAn6KGo6auY44Gu5YCN546HCiAgICBDb25zdCBCQTQgQXMgTG9uZyA9IDEwMDAgICAgJ+ijj+e4puOBruWAjeeOhwogICAgQ29uc3QgQkE1IEFzIExvbmcgPSAxMDAgICAgICfoo4/mqKrjga7lgI3njocKICAgIENvbnN0IEJBNiBBcyBMb25nID0gMTAgICAgICAn6KOP6auY44Gu5YCN546HCiAgICBEaW0gc2gxIEFzIFdvcmtzaGVldCAgICAgICAgJ+WFg+ODh+ODvOOCv+OCt+ODvOODiAogICAgRGltIHNoMiBBcyBXb3Jrc2hlZXQgICAgICAgICfntZDmnpzooajnpLrnlKjjgrfjg7zjg4gKICAgICdEaW0gZGljVCBBcyBPYmplY3QgICAgICAgICAgJ+S7iuWbnuacquS9v+eUqOOBquOBruOBp+OCs+ODoeODs+ODiOOCouOCpuODiOOBl+OBvuOBl+OBnwogICAgRGltIG1heHJvdzEgQXMgTG9uZyAgICAgICAgICflhYPjg4fjg7zjgr/jga7mnIDlpKfooYwKICAgIERpbSBuYW1lcm93IEFzIExvbmcgICAgICAgICAn5ZCN5YmN6KGM77yI5qSc57Si5a++6LGh44Gu5ZCN5YmN44GM44GC44Gj44Gf6KGM77yJ77yI5Z+65rqW44Go44Gq44KL5ZCN5YmN44Gu6KGM77yJCiAgICBEaW0gd3JvdyBBcyBMb25nICAgICAgICAgICAgJ+S9nOalreeUqOihjOeVquWPtyjlhYPjg4fjg7zjgr/jgrfjg7zjg4gpCiAgICBEaW0gcm93MiBBcyBMb25nICAgICAgICAgICAgJ+S9nOalreeUqOihjOeVquWPtyjntZDmnpzooajnpLrnlKjjgrfjg7zjg4gpCiAgICBEaW0gbmFtZSBBcyBTdHJpbmcgICAgICAgICAgJ+WQjeWJje+8iOaknOe0oueUqO+8iQogICAgJ+i3nembouioiOeul+eUqAogICAgRGltIGQxIEFzIExvbmcsIGQyIEFzIExvbmcsIGQxMSBBcyBMb25nLCBkMTIgQXMgTG9uZywgZDEzIEFzIExvbmcsIGQyMSBBcyBMb25nLCBkMjIgQXMgTG9uZywgZDIzIEFzIExvbmcKICAgICdTZXQgZGljVCA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKSAgICAnIOmAo+aDs+mFjeWIl+OBruWumue+qSDku4rlm57mnKrkvb/nlKjjgarjga7jgafjgrPjg6Hjg7Pjg4jjgqLjgqbjg4jjgZfjgb7jgZfjgZ8KICAgIFNldCBzaDEgPSBXb3Jrc2hlZXRzKCJTaGVldDEiKSAgJ+OCt+ODvOODiOioreWumijlhYPjg4fjg7zjgr/jgrfjg7zjg4gpCiAgICBTZXQgc2gyID0gV29ya3NoZWV0cygiU2hlZXQyIikgICfjgrfjg7zjg4joqK3lrpoo57WQ5p6c6KGo56S655So44K344O844OIKQogICAgbWF4cm93MSA9IHNoMS5DZWxscyhSb3dzLkNvdW50LCAxKS5FbmQoeGxVcCkuUm93ICAgICdzaGVldDEg5pyA57WC6KGM44KS5rGC44KB44KLCiAgICBJZiBtYXhyb3cxIDwgNCBUaGVuIEV4aXQgU3ViICAgICfmnIDlpKfooYzjgYw05pyq5rqA44Gq44KJ57WC5LqGCiAgICBuYW1lID0gc2gyLlJhbmdlKCJCMSIpLlZhbHVlICAgICdCMeOBruWGheWuueOCkm5hbWXjgbjoqK3lrpoKICAgIElmIG5hbWUgPSAiIiBUaGVuIEV4aXQgU3ViICAgICAgJ25hbWXjgYznqbrnmb3jgarjgonntYLkuobvvIhCMeOBjOepuueZveOBquOCiee1guS6hu+8iQogICAgc2gyLlJvd3MoIjU6IiAmIFJvd3MuQ291bnQpLkNsZWFyQ29udGVudHMgICAgICAgJzXooYznm67ku6XpmY3jgq/jg6rjgqIKICAgIG5hbWVyb3cgPSAwICAgICAgICAgICAgICAgICAgICAgJ+WQjeWJjeihjOOCkuOCr+ODquOCogogICAgJzPooYzjgYvjgonmnIDntYLooYzjgb7jgafnubDjgorov5TjgZnvvIjlhYPjg4fjg7zjgr/jgrfjg7zjg4jvvIkKICAgIEZvciB3cm93ID0gMyBUbyBtYXhyb3cxCiAgICAgICAgJ+aknOe0oueUqOOBruWQjeWJjeOBqOS4gOiHtOOBl+OBn+WgtOWQiOOAgeOBneOBruihjOOCkuWQjeWJjeihjOOBq+iomOaGtuOBmeOCiwogICAgICAgIElmIG5hbWUgPSBzaDEuQ2VsbHMod3JvdywgMSkuVmFsdWUgVGhlbgogICAgICAgICAgICBuYW1lcm93ID0gd3JvdwogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgJ+WQjeWJjeihjOOBq+ihjOeVquWPt+OBjOioreWumuOBleOCjOOBpuOBhOOBquOBhOOBquOCieOAgee1guS6huOBmeOCiwogICAgSWYgbmFtZXJvdyA9IDAgVGhlbgogICAgICAgIE1zZ0JveCAobmFtZSAmICLjgYzlrZjlnKjjgZfjgb7jgZvjgpMiKSAgICAn44CMWFhY44GM5a2Y5Zyo44GX44G+44Gb44KT44CN44Gu5paH5a2X44KS55S76Z2i44Gr6KGo56S644GZ44KLCiAgICAgICAgRXhpdCBTdWIKICAgIEVuZCBJZgogICAgJ+ODpuODvOOCr+ODquODg+ODiei3nembouOBruioiOeulwogICAgcm93MiA9IDUgICAgJ+e1kOaenOihqOekuueUqOOCt+ODvOODiOOBrjXooYznm67jgYvjgonlh7rlipvjgZnjgosKICAgICcz6KGM44GL44KJ5pyA57WC6KGM44G+44Gn57mw44KK6L+U44GZ77yI5YWD44OH44O844K/44K344O844OI77yJCiAgICBGb3Igd3JvdyA9IDMgVG8gbWF4cm93MQogICAgICAgICflh6bnkIbkuK3jga7ooYzjgYzln7rmupbjgajjgarjgovlkI3liY3jga7ooYzjgafjgarjgYTjgarjgonjgIHot53pm6Ljga7oqIjnrpfjgpLooYzjgYTjgIHntZDmnpzjgrfjg7zjg4jjgbjmm7jjgY3lh7rjgZkKICAgICAgICBJZiB3cm93IDw+IG5hbWVyb3cgVGhlbgogICAgICAgICAgICBzaDIuQ2VsbHMocm93MiwgMSkuVmFsdWUgPSBzaDEuQ2VsbHMod3JvdywgMSkuVmFsdWUgJ+ihqOOBruWQjeWJjQogICAgICAgICAgICBzaDIuQ2VsbHMocm93MiwgNCkuVmFsdWUgPSBzaDEuQ2VsbHMod3JvdywgMSkuVmFsdWUgJ+ijj+OBruWQjeWJjQogICAgICAgICAgICBkMTEgPSAoc2gxLkNlbGxzKHdyb3csIDIpLlZhbHVlIC0gc2gxLkNlbGxzKG5hbWVyb3csIDIpLlZhbHVlKSAgJ+ihqOOBrue4puOBruW3riAgICAg5Yem55CG5Lit44Gu6KGM44Gu57imIO+8jSDln7rmupbjgajjgarjgovlkI3liY3jga7nuKYKICAgICAgICAgICAgZDEyID0gKHNoMS5DZWxscyh3cm93LCAzKS5WYWx1ZSAtIHNoMS5DZWxscyhuYW1lcm93LCAzKS5WYWx1ZSkgICfooajjga7mqKrjga7lt67jgIDjgIAg5Lul5LiL5ZCM5qeYCiAgICAgICAgICAgIGQxMyA9IChzaDEuQ2VsbHMod3JvdywgNCkuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgNCkuVmFsdWUpICAn6KGo44Gu6auY44GV44Gu5beuICAg5Lul5LiL5ZCM5qeYCiAgICAgICAgICAgIGQyMSA9IChzaDEuQ2VsbHMod3JvdywgNSkuVmFsdWUgLSBzaDEuQ2VsbHMobmFtZXJvdywgNSkuVmFsdWUpICAn6KOP44Gu57im44Gu5beuICAgICDku6XkuIvlkIzmp5gKICAgICAgICAgICAgZDIyID0gKHNoMS5DZWxscyh3cm93LCA2KS5WYWx1ZSAtIHNoMS5DZWxscyhuYW1lcm93LCA2KS5WYWx1ZSkgICfoo4/jga7mqKrjga7lt64gICAgIOS7peS4i+WQjOanmAogICAgICAgICAgICBkMjMgPSAoc2gxLkNlbGxzKHdyb3csIDcpLlZhbHVlIC0gc2gxLkNlbGxzKG5hbWVyb3csIDcpLlZhbHVlKSAgJ+ijj+OBrumrmOOBleOBruW3riAgIOS7peS4i+WQjOanmAogICAgICAgICAgICBkMSA9IGQxMSAqIGQxMSAqIEJBMSArIGQxMiAqIGQxMiAqIEJBMiArIGQxMyAqIGQxMyAqIEJBMyAgICAgICAgJ+ihqOOBrue4puOBruW3rl4yKuWAjeeOh++8i+ihqOOBruaoquOBruW3rl4yKuWAjeeOh++8i+ihqOOBrumrmOOBleOBruW3rl4yKuWAjeeOhwogICAgICAgICAgICBkMiA9IGQyMSAqIGQyMSAqIEJBNCArIGQyMiAqIGQyMiAqIEJBNSArIGQyMyAqIGQyMyAqIEJBNiAgICAgICAgJ+ijj+OBrue4puOBruW3rl4yKuWAjeeOh++8i+ijj+OBruaoquOBruW3rl4yKuWAjeeOh++8i+ijj+OBrumrmOOBleOBruW3rl4yKuWAjeeOhwogICAgICAgICAgICBzaDIuQ2VsbHMocm93MiwgMikuVmFsdWUgPSBkMSAgICfooajjga7ot53pm6IKICAgICAgICAgICAgc2gyLkNlbGxzKHJvdzIsIDUpLlZhbHVlID0gZDIgICAn6KOP44Gu6Led6ZuiCiAgICAgICAgICAgIHJvdzIgPSByb3cyICsgMSAn57WQ5p6c6KGo56S655So44K344O844OI44Gu6KGM55Wq5Y+344GrMeWKoOeulwogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgJ+OCveODvOODiAogICAgc2gyLlJhbmdlKCJBNTpCIiAmIHJvdzIgLSAxKS5Tb3J0IGtleTE6PXNoMi5SYW5nZSgiQjUiKSwgT3JkZXIxOj14bEFzY2VuZGluZywgSGVhZGVyOj14bE5vICAn6KGo44Gu44K944O844OI44CA44K944O844OI56+E5ZuyQTU6QuOBruacgOe1guihjAogICAgc2gyLlJhbmdlKCJENTpFIiAmIHJvdzIgLSAxKS5Tb3J0IGtleTE6PXNoMi5SYW5nZSgiRTUiKSwgT3JkZXIxOj14bEFzY2VuZGluZywgSGVhZGVyOj14bE5vICAn6KOP44Gu44K944O844OI44CA44K944O844OI56+E5ZuyRDU6ReOBruacgOe1guihjAogICAgc2gyLlJvd3MoIjEwOiIgJiBSb3dzLkNvdW50KS5DbGVhckNvbnRlbnRzICAgICAgICcxMOihjOebruS7pemZjeOCr+ODquOCou+8iDXku7bov4TooajnpLrjgarjga7jgacxMOihjOebruS7pemZjeOBr+S4jeimge+8iQogICAgTXNnQm94ICgi5a6M5LqGIikgICAgICfjgIzlrozkuobjgI3jga7mloflrZfjgpLnlLvpnaLjgavooajnpLrjgZnjgosKRW5kIFN1Ygo=