Note: The other languages of the website are Google-translated. Back to English

如何在Excel中基於/取決於指定的單元格值自動更改形狀大小?

如果要基於指定單元格的值自動更改形狀大小,本文將為您提供幫助。

使用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

備註:在代碼中,“橢圓形2”是形狀名稱,您將更改其大小。 和 行= 2, 列= 1 表示形狀“橢圓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

筆記:

1)在代碼中,“橢圓形1“”笑臉3“和”心臟3”是形狀的名稱,您將自動更改其大小。 和 A1, A2A3 是您將根據其自動調整形狀大小的值的單元格。
2)如果要添加更多形狀,請添加行“ElseIf xAddress =“ A3”然後“和 “調用SizeCircle(“ Heart 2”,Val(Target.Value))“高於第一個”如果結束代碼中的“”行。然後根據需要更改單元格地址和形狀名稱。

3。 按 其他 + Q 同時關閉按鍵 Microsoft Visual Basic for Applications 窗口。

從現在開始,當您更改單元格A2中的值時,橢圓2形狀的大小將自動更改。 看截圖:

或更改單元格A1,A2和A3中的值,以自動調整相應形狀“橢圓1”,“笑臉3”和“心3”的大小。 看截圖:

備註:單元格值大於10時,形狀大小將不再更改。


列出並導出當前Excel工作簿中的所有形狀:

導出圖形 的效用 Excel的Kutools 幫助您快速列出當前工作簿中的所有形狀,並且可以將其全部導出到特定文件夾,如下圖所示。 立即下載並試用! (30-天免費試用)


相關文章:


最佳辦公效率工具

Kutools for Excel 解決了你的大部分問題,並將你的生產力提高了 80%

  • 重用: 快速插入 複雜的公式,圖表 以及您以前使用過的任何東西; 加密單元 帶密碼 創建郵件列表 並發送電子郵件...
  • 超級公式欄 (輕鬆編輯多行文本和公式); 閱讀版式 (輕鬆讀取和編輯大量單元格); 粘貼到過濾範圍...
  • 合併單元格/行/列 不會丟失數據; 拆分單元格內容; 合併重複的行/列...防止細胞重複; 比較範圍...
  • 選擇重複或唯一 行; 選擇空白行 (所有單元格都是空的); 超級查找和模糊查找 在許多工作簿中; 隨機選擇...
  • 確切的副本 多個單元格,無需更改公式參考; 自動創建參考 到多張紙; 插入項目符號,複選框等...
  • 提取文字,添加文本,按位置刪除, 刪除空間; 創建和打印分頁小計; 在單元格內容和註釋之間轉換...
  • 超級濾鏡 (將過濾方案保存並應用於其他工作表); 高級排序 按月/週/日,頻率及更多; 特殊過濾器 用粗體,斜體...
  • 結合工作簿和工作表; 根據關鍵列合併表; 將數據分割成多個工作表; 批量轉換xls,xlsx和PDF...
  • 超過 300 項強大的功能. 支持 Office / Excel 2007-2021 和 365。支持所有語言。 在您的企業或組織中輕鬆部署。 完整功能 30 天免費試用。 60 天退款保證。
kte選項卡201905

Office選項卡為Office帶來了選項卡式界面,使您的工作更加輕鬆

  • 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,Access,Visio和Project。
  • 在同一窗口的新選項卡中而不是在新窗口中打開並創建多個文檔。
  • 將您的工作效率提高 50%,每天為您減少數百次鼠標點擊!
officetab底部
按評論排序
留言 (16)
還沒有評分。 成為第一位評論!
網站主持人對此評論進行了最小化
您將如何使用多個形狀執行此操作,每個形狀取決於不同的單元格?
網站主持人對此評論進行了最小化
親愛的玉,
這篇文章更新了一個新的代碼部分,它可以幫助您執行多個形狀,每個形狀取決於不同的單元格。 感謝您的評論。

最好的問候,
Crystal 水晶
網站主持人對此評論進行了最小化
如何命名我的形狀? 在上面的示例中,如何將名稱 Oval 2 分配給您繪製的圓圈?
網站主持人對此評論進行了最小化
親愛的蘭吉特,
要命名形狀,請選擇此形狀,在名稱框中輸入形狀名稱,然後按 Enter 鍵。 見下圖所示。
查看附件 (1 / 5)
網站主持人對此評論進行了最小化
嗨,我如何為鏈接到同一模塊中的多個單元格的多個形狀複製相同的內容?
網站主持人對此評論進行了最小化
親愛的阿比納亞,
這篇文章更新了一個新的代碼部分,它可以幫助您執行多個形狀,每個形狀取決於不同的單元格。 感謝您的評論。

最好的問候,
Crystal 水晶
網站主持人對此評論進行了最小化
嗨,
我曾嘗試使用您的帖子編寫我自己的 VBA 代碼,但似乎並沒有走得太遠。 主要是因為我不太了解 VBA,我只是想適應你的。 我想知道你能不能幫忙。 我想根據單元格中的值更改矩形的長度。 如果矩形保持不變但長度改變,我希望寬度。 我希望兩個左手頂點都留在同一個地方,並向右延長。 這可能嗎?
謝謝
網站主持人對此評論進行了最小化
親愛的蘭
希望下面的 VBA 代碼可以解決您的問題。 (請將 Oval 1 替換為您自己的形狀名稱)

Private Sub Worksheet_Change(ByVal Target As Range)
在錯誤恢復下一頁
如果 Target.Row = 2 並且 Target.Column = 1 那麼
調用 SizeCircle("橢圓 1", Val(Target.Value))
如果結束
END SUB
子尺寸圓(名稱為字符串,直徑)
將 xCircle 調暗為形狀
將 xDiameter 變暗為單個
出錯 GoTo ExitSub
xDiameter = 直徑
如果 xDiameter > 10 那麼 xDiameter = 10
如果 xDiameter < 1 那麼 xDiameter = 1
設置 xCircle = ActiveSheet.Shapes(Name)
xCircle.ScaleWidth 1.5,msoFalse,msoScaleFromTopLeft
使用 xCircle
.LockAspectRatio = msoFalse
.Width = Application.CentimetersToPoints(xDiameter)
結束
退出子:
END SUB
網站主持人對此評論進行了最小化
嗨,有沒有辦法讓形狀在二維上擴展(而不是將形狀大小增加 5,在水平方向增加 5,在垂直方向增加 3)?
網站主持人對此評論進行了最小化
親愛的山姆,
以下 VBA 腳本可以幫助您解決問題。 這兩個維度是單元格 A1 和 B1。

Private Sub Worksheet_Change(ByVal Target As Range)
在錯誤恢復下一頁
如果 Target.Count = 1 那麼
If Not Intersect(Target, Range("A1:B1")) 什麼都不是
調用 SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
如果結束
如果結束
END SUB
Sub SizeCircle(名稱為字符串,Arr 為變體)
暗淡我只要
將 xCenterX 調暗為單個
將 xCenterY 調暗為單一
將 xCircle 調暗為形狀
出錯 GoTo ExitSub
對於 I = 0 到 UBound(Arr)
如果 Arr(I) > 10 那麼
排列(一)= 10
ElseIf Arr(I) < 1 Then
排列(一)= 1
如果結束
下一頁
設置 xCircle = ActiveSheet.Shapes(Name)
使用 xCircle
xCenterX = .Left + (.Width / 2)
xCenterY = .Top + (.Height / 2)
.Width = Application.CentimetersToPoints(Arr(0))
.Height = Application.CenimetersToPoints(Arr(1))
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.Height / 2)
結束
退出子:
END SUB
網站主持人對此評論進行了最小化
有沒有辦法用圖像做到這一點? 使用發布的代碼,我似乎沒有任何運氣。

排行榜中有 5 張圖片,我希望第一名或併列第一名的圖片更大。 因此,我有 1 個固定的圖像尺寸,1x2 不是第一名,或者 1x2 是第一名(例如)。 我已經設置了排名,因此可以使用它在每個圖像的特定單元格中創建尺寸(即使用 IF 語句,因此 IF RANK 是第一個尺寸寬度為 2)。 我的VBA雖然很弱。

基本上我想要 - 在工作表更新時 - 查看圖像大小的單元格並將每個圖像大小設置為特定的圖像大小單元格結果。 我在上面的 VBA 中看不到它是如何工作的,但我認為它應該很容易!
網站主持人對此評論進行了最小化
嗨水晶,

我想問你,是否有辦法從特定單元格中選擇顏色(紅色單元格 = 紅色表格)和名稱。 是否也可以從 VBA 自動創建表單?

提前非常感謝你:)

楊嘉樂
網站主持人對此評論進行了最小化
嗨水晶
如果要確定立方體、三角形、盒子的邊必鬚根據長、寬來確定怎麼辦? 請幫我

謝謝
主席
網站主持人對此評論進行了最小化
嗨主席,
抱歉還不能幫你。 謝謝你的評論。
網站主持人對此評論進行了最小化
如果您用來設置大小的單元格是公式的結果,而不僅僅是您手動輸入的靜態值,有沒有辦法讓它工作?
網站主持人對此評論進行了最小化
您好 mathnz,下面的 VBA 代碼可以幫助您解決問題。您只需根據自己的數據更改代碼中的值單元格和形狀名稱。
私有子 Worksheet_Calculate()
'更新者 Extendoffice 20211105
在錯誤恢復下一頁
調用 SizeCircle("Oval 1", Val(Range("A1").Value)) 'A1 是值單元格,橢圓 1 是形狀名稱
調用 SizeCircle("笑臉 2", Val(Range("A2").Value))
調用 SizeCircle("Heart 3", Val(Range("A3").Value))

END SUB
Private Sub Worksheet_Change(ByVal Target As Range)
將 xAddress 變暗為字符串
在錯誤恢復下一頁
如果 Target.CountLarge = 1 那麼
xAddress = Target.Address(0, 0)
如果 xAddress = "A1" 那麼
調用 SizeCircle("橢圓 1", Val(Target.Value))
ElseIf xAddress =“ A2”然後
調用 SizeCircle("笑臉 2", Val(Target.Value))
ElseIf xAddress =“ A3”然後
調用 SizeCircle("Heart 3", Val(Target.Value))

如果結束
如果結束
END SUB

子尺寸圓(名稱為字符串,直徑)
將 xCenterX 調暗為單個
將 xCenterY 調暗為單一
將 xCircle 調暗為形狀
將 xDiameter 變暗為單個
出錯 GoTo ExitSub
xDiameter = 直徑
如果 xDiameter > 10 那麼 xDiameter = 10
如果 xDiameter < 1 那麼 xDiameter = 1
設置 xCircle = ActiveSheet.Shapes(Name)
使用 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 SUB

這裡還沒有評論
留下你的意見
以訪客身份發帖
×
評價此帖子:
0   字符
推薦地點

關注我們

版權所有©2009 - 萬維網。extendoffice.com。 | 版權所有。 供電 ExtendOffice。 |
Microsoft和Office徽標是Microsoft Corporation在美國和/或其他國家的商標或註冊商標。
受Sectigo SSL保護