[[20250819162015]]　『楕円で囲んだ文字を取得する』（東九）　ページの最後に飛ぶ

『楕円で囲んだ文字を取得する』（東九）

単一セルに「昭和平成令和」とあります。
元号を図形楕円で囲んでいます。
囲まれた元号の文字を取得するすることは出来ますか。

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

 オートシェイプの座標とセルの座標の比較で、
 できなくもないような気がしますが、正解率100%は保証できないと思います

 オートシェイプがセルの　左側あたり、真ん中あたり、右側あたり　くらいの判定です。
 昭和 平成 令和 がセルのどのあたりに配置されているかが問題になるので、
 試しながら調整する必要があるかもしれません

 紙の帳票の見た目だけを再現してしまうと、処理を自動化する場合の足かせになりますね
 デジタル時代にはデジタル時代にあった帳票の作り方が必要です
（ ´・ω・`） 2025/08/19(火) 17:09:58

リスト選択にするとか「1:昭和　2:平成　3:令和」で隣に番号を入れさせるとか
やり方を見直したほうがいいんじゃないでしょうか。
（d-q-t-p） 2025/08/19(火) 17:15:02

 こういう方法はいかがでしょう？

[[20250403141506]]　『画像自動変換を使って表作成』（いわ）
（OK） 2025/08/19(火) 18:02:11

＞デジタル時代にはデジタル時代にあった帳票の作り方が必要です
＞やり方を見直したほうがいいんじゃないでしょうか。
を考慮して考えてみます。
＞こういう方法はいかがでしょう？
希望している結果と異なるので使用できません。
（東九） 2025/08/19(火) 21:02:29

 右隣のセルに結果を返す場合。
Sub Oval_Enclosed()
  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
  Application.ScreenUpdating = False
  For Each s In ActiveSheet.Shapes
    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
                If g.Left < px And px < g.Left + g.Width Then
                  If g.Top < py And py < g.Top + g.Height Then
                    r.Offset(0, 1).Value = g.TextFrame.Characters.Text
                    Exit For
                  End If
                End If
              End If
            End If
          Next
          ShpRng.Delete
      End Select
    End If
  Next s
  Application.ScreenUpdating = True
End Sub
（んなっと） 2025/08/20(水) 16:44:53

コメント返信：

[ 一覧(最新更新順) ]

[[20250819162015]] 『楕円で囲んだ文字を取得する』（東九） ページの最後に飛ぶ

[[20250819162015]]　『楕円で囲んだ文字を取得する』（東九）　ページの最後に飛ぶ