公開日：2024/07/31

エクセルで文字を自動的に丸で囲む簡単な方法

エクセルで文字を自動的に丸で囲む方法をご紹介します。

自動的に丸で囲むことで、例えばエクセルで作成した出席表の「出席の有無」について「有」か「無」に丸をする必要がある場合などに役立てられます。

VBAを使用しますがコードを記載しますので、エクセル初心者の方でも簡単に設定ができます。

エクセルで文字を自動的に丸で囲む簡単な方法

エクセルで文字を自動的に丸で囲む方法をご紹介します。

今回はVBAを使って設定します。

開発タブを表示する

VBAの設定は「開発タブ」から行います。

開発タブはデフォルトでは表示されていないので、以下の記事で表示させましょう。

エクセルの開発タブを表示する方法

VBAを使って文字を自動的に丸で囲む設定を行う

VBAを使って、特定の文字を自動的に丸で囲むように設定を行います。

今回はあらかじめ丸で囲みたい文字をリスト化しておいて、マクロを実行するとリスト内と同じ文字を探して図形の丸で囲むようにVBAを設定します。

例えば、「有」とリストに入力しておけばシート内に「有」の文字があった場合に図形の丸で囲みます。

丸の大きさはセルの幅に合わせます。

方法の詳細は以下のとおりです。

①「開発」タブ、②「Visual Basic」の順に選択します。

「Microsoft Visual Basic for Applications」というVBAの編集画面が表示されます。

①「新しい標準モジュール」、②「標準モジュール」の順に選択します。

以下のコードをコピーして貼り付けます。

上記の画像の緑色の文字は、各コードが何の動作を指定しているかを説明しているコメントです。コピー用のコードではコメントを省いています。

あらかじめ丸で囲みたい文字をSheet2のA1セルからA10セルにリスト化しておいて、マクロを実行するとリスト内と同じ文字をSheet1から探して図形の丸で囲む、という意味のコードになります。

Sub 自動的に丸で囲む()
    Dim ws As Worksheet
    Dim listWs As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") 
    Set listWs = ThisWorkbook.Sheets("Sheet2") 
    Dim cell As Range
    Dim listCell As Range
    Dim text As String
    Dim foundPos As Integer
    Dim circledChar As String
    Dim startPos As Double
    Dim shp As Shape
    
    Dim listRange As Range
    Set listRange = listWs.Range("A1:A10")
    
    For Each shp In ws.Shapes
        If shp.AutoShapeType = msoShapeOval Then
            shp.Delete
        End If
    Next shp

    For Each cell In ws.UsedRange
        text = cell.Value
        

        For Each listCell In listRange
            circledChar = listCell.Value
            foundPos = InStr(text, circledChar)
            If foundPos > 0 Then
                
                startPos = cell.Left + (foundPos - 1) * (cell.Width / Len(text))
                Dim circleWidth As Double
                circleWidth = cell.Width / Len(text)
                
                Set shp = ws.Shapes.AddShape(msoShapeOval, startPos, cell.Top, circleWidth, cell.Height)
                
                With shp
                    .Line.ForeColor.RGB = RGB(0, 0, 0) 
                    .Line.Weight = 1 
                    .Fill.Transparency = 1 
                End With
               
                Do While foundPos > 0
                    text = Replace(text, circledChar, "", 1, 1)
                    foundPos = InStr(text, circledChar)
                    If foundPos > 0 Then
                        startPos = cell.Left + (foundPos - 1) * (cell.Width / Len(text))
                        Set shp = ws.Shapes.AddShape(msoShapeOval, startPos, cell.Top, circleWidth, cell.Height)
                        
                        With shp
                            .Line.ForeColor.RGB = RGB(0, 0, 0)
                            .Line.Weight = 1
                            .Fill.Transparency = 1
                        End With
                    End If
                Loop
            End If
        Next listCell
    Next cell
End Sub

シート名を変更したい場合は、4行目と5行目の「"Sheet1"」「"Sheet2"」を変更しましょう。

Sheet2のリストを入力する位置を変更したい場合は、15行目の「Set listRange = listWs.Range("A1:A10")」の「("A1:A10")」のセル範囲を変更しましょう。