『楕円で囲んだ文字を取得するその2』（東九）
下記の表のように数字に楕円で囲まれた右横の文字をF列に表示したい のですがマクロのヒントを教えて頂けますか。
|[A] |[B]|[C]|[D]|[E]|[F]
[2]|1 昭和 2 平成 ?B 令和 | | | | |令和
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
ちょっと手間取りましたがAIで作ってみました。 オブジェクトの位置判定を中心でするようにし、選択対象は数字を対象として右側の文字列を出すように指示して、修正しました。 A2 は 「1 昭和 2 平成 3 令和」（数字の前後にスペース）の想定です。
Sub DetectClosestNumberAndOutput()
Dim shp As Shape
Dim targetCell As Range
Dim txt As String
Dim arr As Variant
Dim i As Long
'判定セル（例：A2）
Set targetCell = Range("A2")
'セル内テキスト取得
txt = targetCell.Value
arr = Split(txt, " ")
'セル位置
Dim cLeft As Double, cTop As Double, cRight As Double, cBottom As Double
cLeft = targetCell.Left
cTop = targetCell.Top
cRight = cLeft + targetCell.Width
cBottom = cTop + targetCell.Height
'シート内の Shape を走査
For Each shp In ActiveSheet.Shapes
If shp.Type = msoAutoShape Then
'--- Shape の中心点 ---
Dim centerX As Double, centerY As Double
centerX = shp.Left + shp.Width / 2
centerY = shp.Top + shp.Height / 2
'◆ センターが対象セル内でないなら無視
If Not (centerX >= cLeft And centerX <= cRight And _
centerY >= cTop And centerY <= cBottom) Then
GoTo ContinueLoop
End If
'-------------------------
' 数字の位置と中心の距離を測る
'-------------------------
Dim pos As Double: pos = cLeft
Dim nearestNumIndex As Long: nearestNumIndex = -1
Dim nearestDist As Double: nearestDist = 1E+20
For i = 0 To UBound(arr)
Dim w As Double
w = GetTextWidth(arr(i), targetCell.Font)
'数字かどうか判定（半角/全角は後述の改善で対応可）
If IsNumeric(arr(i)) Then
'数字の中央位置
Dim wordCenter As Double
wordCenter = pos + w / 2
'楕円中心との距離
Dim d As Double
d = Abs(centerX - wordCenter)
'最小距離を更新
If d < nearestDist Then
nearestDist = d
nearestNumIndex = i
End If
End If
pos = pos + w + 5 'スペース幅（環境により調整）
Next i
'最も近い数字が見つかったら
If nearestNumIndex >= 0 Then
If nearestNumIndex < UBound(arr) Then
Range("F" & targetCell.Row).Value = arr(nearestNumIndex + 1)
End If
End If
End If
ContinueLoop:
Next shp
End Sub
'▼ テキスト幅取得（引数を Variant/Object にして内部で文字列化）
Function GetTextWidth(textVar As Variant, f As Object) As Double
Dim s As String
s = CStr(textVar) 'Variant を String に変換（安全）
Dim tb As Shape
'一時テキストボックスを追加して幅を測る
Set tb = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 10, 10)
With tb.TextFrame
.Characters.Text = s
.Characters.Font.Name = f.Name
.Characters.Font.Size = f.Size
'AutoSize を使ってテキストに合わせる（環境により動かない場合は削除）
On Error Resume Next
.AutoSize = True
On Error GoTo 0
End With
GetTextWidth = tb.Width
tb.Delete
End Function
（英愛） 2025/11/30(日) 18:46:49
A2に｢1 昭和｣、B2に｢2 平成｣、C2に｢3 令和｣ って感じで、セル分けできないですか？
|[A] |[B] |[C] |[D]|[E]|[F]
[2]|1 昭和|2 平成|3 令和| | |
上のようにできるのなら、処理も楽になると思うんですけど・・・
Sub Sample()
Dim shp As Shape, x As Double, y As Double
Dim target As Range: Set target = ActiveSheet.Range("A2:C2")
Dim output As Range: Set output = ActiveSheet.Range("F2")
Dim r As Range
output = ""
For Each shp In ActiveSheet.Shapes
x = shp.Left + shp.Width / 2 '図形の中心(X座標)を計算
y = shp.Top + shp.Height / 2 '図形の中心(Y座標)を計算
For Each r In target
If r.Left <= x And r.Left + r.Width >= x And _
r.Top <= y And r.Top + r.Height >= y Then
'セル内に図形中心があれば、
output = Mid(r.Text, 3) '３文字目以降を出力
End If
Next r
Next shp
End Sub
（通行人） 2025/11/30(日) 22:07:42
英愛さんへ、確認の質問です。
平成の2の付近に〇をつけても、昭和が返ってくることがあります。 w = GetTextWidth(arr(i), targetCell.Font) が過大評価されているようです。
w = GetTextWidth(" ", targetCell.Font)
としたら何が返りますか？ 5に近い数値が返りますか？
そしてそれは実際のものに近いのですか？
そこをステップ実行して確認すると原因がわかると思われます。
# ユーザーに楕円を描かせるのであれば、前回スレッドでも議論がありましたように # 余り適切なUIではないと思われます。"1,2,3のいずれかを入力させる"というのは # 結構一般的になっている気がします。
（xyz） 2025/12/01(月) 14:06:11
ほぼ同じですが...
Sub Oval_Enclosed2()
Dim i As Long
Dim r As Range, Shp As Shape, ShpRng As ShapeRange
Dim s As Shape, g As Shape
Dim ft As Long
Dim px As Single, py As Single
Dim Cnt As Long
Application.ScreenUpdating = False
For Each s In ActiveSheet.Shapes
Cnt = 0
If s.Type = msoAutoShape Then
Select Case s.AutoShapeType
Case msoShapeOval, msoShapeNotPrimitive
px = s.Left + s.Width / 2
py = s.Top + s.Height / 2
Set r = s.TopLeftCell
ft = r.Font.Color
For i = 1 To r.Characters.Count
Select Case r.Characters(i, 1).Text
Case " ", " ", "・"
r.Characters(i, 1).Font.Color = vbWhite
End Select
Next i
r.CopyPicture Appearance:=xlScreen, Format:=xlPicture
r.Font.Color = ft
ActiveSheet.PasteSpecial Format:="Microsoft Office 描画オブジェクト"
Set Shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
Set ShpRng = Shp.Ungroup
For Each g In ShpRng.GroupItems
Select Case g.AutoShapeType
Case msoShapeOval, msoShapeNotPrimitive
px = g.Left + g.Width / 2
py = g.Top + g.Height / 2
Exit For
End Select
Next
For Each g In ShpRng.GroupItems
If g.AutoShapeType = msoShapeRectangle Then
If g.TextFrame.Characters.Count > 0 Then
Select Case g.TextFrame.Characters.Text
Case " ", " ", "・"
Case Else
If Cnt = 1 Then
r.Offset(0, 1).Value = g.TextFrame.Characters.Text
Exit For
ElseIf g.Left < px And px < g.Left + g.Width Then
If g.Top < py And py < g.Top + g.Height Then
Cnt = Cnt + 1
End If
End If
End Select
End If
End If
Next
ShpRng.Delete
End Select
End If
Next s
Application.ScreenUpdating = True
End Sub
（んなっと） 2025/12/01(月) 15:03:01
F列の場合は
r.Offset(0, 5).Value = g.TextFrame.Characters.Text
ですね。自分で見つけて直してください。
（んなっと） 2025/12/01(月) 15:06:16
あまり精緻なことしないで、これくらいざっくりでいいと思いますが、どうですか？
Sub test()
Debug.Print GetEra(ActiveSheet.Shapes("Oval 1"))
End Sub
Function GetEra(shp As Shape) As String
Dim cellWidth As Double
cellWidth = Columns("A").Width
Select Case True
Case shp.Left < cellWidth / 3: GetEra = "昭和"
Case shp.Left < cellWidth * 2 / 3: GetEra = "平成"
Case Else: GetEra = "令和"
End Select
End Function
（´・ω・`） 2025/12/01(月) 15:32:31
shp.Left より shp.Right を使った方がいいかも （´・ω・`） 2025/12/01(月) 15:34:01
真面目にやってみました
Sub test()
Debug.Print GetOvalChar(Range("A2"), ActiveSheet.Shapes("Oval 1"))
End Sub
Function GetOvalChar(c As Range, shp As Shape)
Dim w As Worksheet, ret As String
Set w = c.Parent
With w.Shapes.AddShape(msoShapeRectangle, c.Left, c.Top + c.Height, c.Width, c.Height)
.Line.Weight = 0
With .TextFrame2
.WordWrap = msoFalse
.AutoSize = msoAutoSizeShapeToFitText
.MarginLeft = 0
.MarginRight = 0
.MarginBottom = 0
.MarginTop = 0
End With
For i = 1 To c.Characters.Count
.TextFrame2.TextRange.Text = c.Characters(1, i).Text
For j = 1 To i
With .TextFrame2.TextRange.Characters(i, 1).Font
.NameFarEast = c.Characters(i, 1).Font.Name
.Name = c.Characters(i, 1).Font.Name
.Size = c.Characters(i, 1).Font.Size
End With
Next
Debug.Print i; c.Characters(i, 1).Text
If shp.Left < .Left + .Width And .Left + .Width < shp.Left + shp.Width Then
ret = ret & c.Characters(i, 1).Text
End If
If shp.Left + shp.Width < .Left + .Width Then
.Delete
GetOvalChar = ret
Exit Function
End If
Next
End With
End Function
（´・ω・`） 2025/12/01(月) 16:57:10
あ、当方365で作っているので、Excel2013 では動かないかも。 こちらでは、Excel2013の環境を作れない（こともないけど、その気がない）ので、ご了承ください （´・ω・`） 2025/12/01(月) 17:04:49
（通行人）さん ＞セル分けできないですか？
様式が決まっているためできません。
（´・ω・`）さん ＞これくらいざっくりでいいと思いますが、どうですか？
＞真面目にやってみました
語句が増えた場合、その都度登録しなければならないのでだめです。
他人に使用してもらうためにも避けたいてのです。
質問内容とまるっきり違います。使用できません。使用しません。
回答してくれた方々ありがとうございました。
(んなっと)さん前回返事するのを忘れていました。
選択セルのみに変更して使用しています。
今回も使用させていただきます。問題ありません。
クローズさせていただきます。
（東九） 2025/12/01(月) 20:07:42
英愛さんから返事がないのでこちらで調べた結果を書きます。
ダミーのtextBoxを作ったとき、左右のマージンが0になっていないのが普通なので、
それが悪さをして横幅、さらにはposという位置変数が過大になっていくのです。
左右のマージンを0にすると改善します。
（これは、
w = GetTextWidth(" ", targetCell.Font)
をステップ実行してみると、やけに横幅が広くなるので、直ぐに気づきます。）
また、これを使えば、「スペース幅（環境により調整）」は、避けられます。
生成AIの回答は十分な検証が必要です。 生成AIを使用した回答の妥当性の検証は、まずは回答者が負っていただきたい、というのが私の意見です。
---------- 以下は、質問者さんへのコメントです。
> 語句が増えた場合、その都度登録しなければならないのでだめです。 これはどういうことでしょうか。 語句が増えるとはどういうことですか？明治、大正などもあるということですか？ それとも年号選択以外のことを言っているのでしょうか。 仕様の説明が不十分だったのではないでしょうか。 予め明確に説明されたほうが良かったと思います。
> 質問内容とまるっきり違います。使用できません。使用しません。 これも理解しかねます。
（´・ω・`）さんが提示されたコードは、考え方を質問者さんに説明するためのコードであって、 あとはその考え方を理解して、ご自分で実際に適用して欲しいという積りで回答されているはずです。 そのまま使用できるものじゃないから却下、というのはあんまりです。 そもそも、 > マクロのヒントを教えて頂けますか と書いていますよね。 ヒントとして有用だと思いました。 折角わざわざ時間を割いた結果のコメントを得ているのに、随分な対応だと思いました。
--------- > # ユーザーに楕円を描かせるのであれば、前回スレッドでも議論がありましたように > # 余り適切なUIではないと思われます。 と書いたのは、例えば、 2 平成 の全体を楕円で囲む人も出てくるでしょう。(注意書きがあっても） そのときは、例えば、んなっとさんの方式だと、 3 が結果に帰ってきます。 また、楕円が当該セルのtop位置の上に少しでもはみ出すと、適切な結果が得られません。
このように、「ユーザーに楕円を描かせる」方式には、色々な隘路があるので、注意が必要です。 できれば「楕円で囲む」方式ではなく、デジタル式？のインターフェイスを検討することをお薦めします。
（xyz） 2025/12/01(月) 21:45:57
既に統一規格で作成されてしまった多くのブックから、必要な結果をVBAを使って取り出したい。 今後はチェックボックスを使う仕様に変更する予定…というということですよね？ 問題ないと思いますよ。 ご自分で問題点に気付き、ある程度の対応ができる方のようです。自信を持って続けてください。
（んなっと） 2025/12/01(月) 23:11:01
こういう態度の質問者には私は二度と回答しません ハンドルネームは変えないようにおねがいしまます （´・ω・`） 2025/12/01(月) 23:54:39
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.