暇つぶしに組んでみたけどこれめっちゃ面倒ね 右上から時計回り。Left, Top座標(単位はポイント) Sub 座標取得() Dim ws As Worksheet Dim rng As Range, r As Range Dim n As Long, cnt As Long, cnt_ As Long, i As Long, d As Long Dim 結果() As Variant, tmp As Variant Application.ScreenUpdating = False Set rng = Selection If rng.Count = 1 Then Exit Sub Set ws = ThisWorkbook.Worksheets.Add '作業用兼結果表示シート追加 With ws .Cells(1, 1).Value = "Left" .Cells(1, 2).Value = "Top" '選択範囲内各セルの四隅の座標を作業用シートに書き出す For Each r In rng n = .Cells(Rows.Count, 1).End(xlUp).Row + 1 .Cells(n, 1).Value = r.Left .Cells(n, 2).Value = r.Top n = n + 1 .Cells(n, 1).Value = r.Left .Cells(n, 2).Value = r.Top + r.Height n = n + 1 .Cells(n, 1).Value = r.Left + r.Width .Cells(n, 2).Value = r.Top n = n + 1 .Cells(n, 1).Value = r.Left + r.Width .Cells(n, 2).Value = r.Top + r.Height Next '昇順でソート n = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A2:B" & n).Sort .Range("A2"), xlAscending, _ .Range("B2"), , xlAscending '重複2 or 4の座標は削除、重複3は1つ残して削除 For i = 2 To n cnt = WorksheetFunction.CountIfs(.Range("A2:A" & n), _ .Cells(i, 1).Value, .Range("B2:B" & n), .Cells(i, 2).Value) If cnt >= 2 And cnt <= 4 Then If Selection.Count > 1 Then If cnt = 3 Then Application.Union(Selection, _ .Cells(i, 1).Resize(cnt - 1, 1).EntireRow).Select Else Application.Union(Selection, _ .Cells(i, 1).Resize(cnt, 1).EntireRow).Select End If Else If cnt = 3 Then .Cells(i, 1).Resize(cnt - 1, 1).EntireRow.Select Else .Cells(i, 1).Resize(cnt, 1).EntireRow.Select End If End If i = i + cnt - 1 End If Next i Selection.Delete n = .Cells(Rows.Count, 1).End(xlUp).Row Set r = .Range("A2:B" & n) tmp = r.Value ReDim 結果(1 To n - 1, 1 To 2) '始点の取得（最右上） 結果(1, 1) = WorksheetFunction.Max(.Range("A2:A" & n)) 結果(1, 2) = WorksheetFunction.VLookup(結果(1, 1), r, 2, False) '時計回りで座標を探して並び替えていく cnt = 1 d = 3 '右上始点なので下方向から開始(1:上, 2:右, 3:下, 4:左) Do cnt_ = cnt_ + 1 'ループカウンタ If cnt = n - 1 Then Exit Do If cnt_ > cnt Then Exit Do '無限ループ回避用 Select Case d Case 1 '上方向の座標を探す For i = n - 1 To 1 Step -1 If tmp(i, 1) = 結果(cnt, 1) Then If tmp(i, 2) < 結果(cnt, 2) Then cnt = cnt + 1 結果(cnt, 1) = tmp(i, 1) 結果(cnt, 2) = tmp(i, 2) d = next_d(rng, d, tmp(i, 1), tmp(i, 2)) Exit For End If End If Next i Case 2 '右方向の座標を探す For i = 1 To n - 1 If tmp(i, 2) = 結果(cnt, 2) Then If tmp(i, 1) > 結果(cnt, 1) Then cnt = cnt + 1 結果(cnt, 1) = tmp(i, 1) 結果(cnt, 2) = tmp(i, 2) d = next_d(rng, d, tmp(i, 1), tmp(i, 2)) Exit For End If End If Next i '続く