指定されたセルの値に基づいて図形のサイズを自動変更するには？

指定されたセルの値に基づいて図形のサイズを自動的に変更したい場合、この記事がお役に立つでしょう。

VBAコードを使用して、指定されたセルの値に基づいて図形のサイズを自動変更する

VBAコードを使用して、指定されたセルの値に基づいて図形のサイズを自動変更する

次のVBAコードは、現在のワークシート内の指定されたセルの値に基づいて特定の図形のサイズを変更するのに役立ちます。以下の手順で行ってください。

1. サイズを変更する図形があるシートタブを右クリックし、「 コードの表示」をクリックします。

2. Microsoft Visual Basic for Applicationsウィンドウで、次のVBAコードをコピーしてコードウィンドウに貼り付けます。

VBAコード：Excelで指定されたセルの値に基づいて図形のサイズを自動変更する

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Row = 2 And Target.Column = 1 Then
        Call SizeCircle("Oval 2", Val(Target.Value))
    End If
End Sub
Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    On Error GoTo ExitSub
    xDiameter = Diameter
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
ExitSub:
End Sub

注：コード内では、「Oval 2」はサイズを変更する図形の名前です。「Row = 2」「 Column = 1」は、図形「Oval 2」のサイズがA2の値によって変更されることを意味します。必要に応じてこれらを変更してください。

異なるセルの値に基づいて複数の図形を自動的にリサイズするには、次のVBAコードを適用してください。

VBAコード：Excelで異なる指定されたセルの値に基づいて複数の図形を自動リサイズする

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xAddress As String
    On Error Resume Next
    If Target.CountLarge = 1 Then
        xAddress = Target.Address(0, 0)
        If xAddress = "A1" Then
            Call SizeCircle("Oval 1", Val(Target.Value))
        ElseIf xAddress = "A2" Then
            Call SizeCircle("Smiley Face 3", Val(Target.Value))
        ElseIf xAddress = "A3" Then
            Call SizeCircle("Heart 2", Val(Target.Value))
        End If
    End If
End Sub

Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    On Error GoTo ExitSub
    xDiameter = Diameter
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
ExitSub:
End Sub

注意事項：

3. Alt + Qキーを同時に押して、Microsoft Visual Basic for Applicationsウィンドウを閉じます。

これで、A2の値を変更すると、図形「Oval 2」のサイズが自動的に変更されます。スクリーンショットをご覧ください：

または、A1、A2、A3の値を変更して、対応する図形「Oval 1」「Smiley Face 3」「Heart 3」を自動的にリサイズすることもできます。スクリーンショットをご覧ください：

注：セルの値が10より大きい場合、図形のサイズはそれ以上変更されません。

関連記事：

• Excelで特定の図形にマウスオーバーヒントを追加するには？
• Excelで透明な背景色で図形を塗りつぶすには？
• Excelで指定されたセルの値に基づいて特定の図形を非表示または再表示するには？