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

วิธีเปลี่ยนขนาดรูปร่างโดยอัตโนมัติตาม / ขึ้นอยู่กับค่าเซลล์ที่ระบุใน Excel

หากคุณต้องการเปลี่ยนขนาดรูปร่างโดยอัตโนมัติตามค่าของเซลล์ที่ระบุบทความนี้สามารถช่วยคุณได้

เปลี่ยนขนาดรูปร่างโดยอัตโนมัติตามค่าเซลล์ที่ระบุด้วยรหัส VBA


เปลี่ยนขนาดรูปร่างโดยอัตโนมัติตามค่าเซลล์ที่ระบุด้วยรหัส VBA

รหัส VBA ต่อไปนี้สามารถช่วยคุณในการเปลี่ยนขนาดรูปร่างตามค่าของเซลล์ที่ระบุในแผ่นงานปัจจุบัน กรุณาดำเนินการดังนี้

1. คลิกขวาที่แท็บแผ่นงานที่มีรูปร่างที่คุณต้องการเปลี่ยนขนาดจากนั้นคลิก ดูรหัส จากเมนูคลิกขวา

2 ใน Microsoft Visual Basic สำหรับแอปพลิเคชัน คัดลอกและวางรหัส 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, A2 และ A3 คือเซลล์ที่คุณจะปรับขนาดรูปร่างโดยอัตโนมัติตามค่า
2) หากต้องการเพิ่มรูปทรงโปรดเพิ่มเส้น "ElseIf xAddress = "A3" จากนั้น"และ "Call SizeCircle (" Heart 2 ", Val (Target.Value))"เหนือข้อแรก"End If"ในรหัสและเปลี่ยนที่อยู่เซลล์และชื่อรูปร่างตามความต้องการของคุณ

3 กด อื่น ๆ + Q พร้อมกันเพื่อปิดไฟล์ Microsoft Visual Basic สำหรับแอปพลิเคชัน หน้าต่าง

จากนี้ไปเมื่อคุณเปลี่ยนค่าในเซลล์ A2 ขนาดของรูปร่าง Oval 2 จะเปลี่ยนโดยอัตโนมัติ ดูภาพหน้าจอ:

หรือเปลี่ยนค่าในเซลล์ A1, A2 และ A3 เพื่อปรับขนาดรูปร่างที่สอดคล้องกัน "Oval 1", "Smiley Face 3" และ "Heart 3" โดยอัตโนมัติ ดูภาพหน้าจอ:

หมายเหตุ: ขนาดรูปร่างจะไม่เปลี่ยนแปลงอีกต่อไปเมื่อค่าของเซลล์มากกว่า 10


แสดงรายการและส่งออกรูปร่างทั้งหมดในสมุดงาน Excel ปัจจุบัน:

พื้นที่ ส่งออกกราฟิก ประโยชน์ของ Kutools สำหรับ Excel ช่วยให้คุณแสดงรายการรูปร่างทั้งหมดในสมุดงานปัจจุบันได้อย่างรวดเร็วและคุณสามารถส่งออกรูปทรงทั้งหมดไปยังโฟลเดอร์ใดโฟลเดอร์หนึ่งได้พร้อมกันดังภาพหน้าจอด้านล่าง ดาวน์โหลดและทดลองใช้ทันที! (30เส้นทางฟรีวัน)


บทความที่เกี่ยวข้อง:


เครื่องมือเพิ่มประสิทธิภาพการทำงานในสำนักงานที่ดีที่สุด

Kutools สำหรับ Excel แก้ปัญหาส่วนใหญ่ของคุณและเพิ่มผลผลิตของคุณได้ถึง 80%

  • นำมาใช้ใหม่: ใส่อย่างรวดเร็ว สูตรที่ซับซ้อนแผนภูมิ และสิ่งที่คุณเคยใช้มาก่อน เข้ารหัสเซลล์ ด้วยรหัสผ่าน; สร้างรายชื่อผู้รับจดหมาย และส่งอีเมล ...
  • ซุปเปอร์ฟอร์มูล่าบาร์ (แก้ไขข้อความและสูตรหลายบรรทัดได้อย่างง่ายดาย); การอ่านเค้าโครง (อ่านและแก้ไขเซลล์จำนวนมากได้อย่างง่ายดาย); วางลงในช่วงที่กรองแล้ว...
  • ผสานเซลล์ / แถว / คอลัมน์ โดยไม่สูญเสียข้อมูล แยกเนื้อหาของเซลล์ รวมแถว / คอลัมน์ที่ซ้ำกัน... ป้องกันเซลล์ซ้ำ; เปรียบเทียบช่วง...
  • เลือกซ้ำหรือไม่ซ้ำ แถว; เลือกแถวว่าง (เซลล์ทั้งหมดว่างเปล่า); Super Find และ Fuzzy Find ในสมุดงานจำนวนมาก สุ่มเลือก ...
  • สำเนาถูกต้อง หลายเซลล์โดยไม่เปลี่ยนการอ้างอิงสูตร สร้างการอ้างอิงอัตโนมัติ ถึงหลายแผ่น ใส่สัญลักษณ์แสดงหัวข้อย่อย, กล่องกาเครื่องหมายและอื่น ๆ ...
  • แยกข้อความ, เพิ่มข้อความ, ลบตามตำแหน่ง, ลบ Space; สร้างและพิมพ์ผลรวมย่อยของเพจ แปลงระหว่างเนื้อหาของเซลล์และความคิดเห็น...
  • ซุปเปอร์ฟิลเตอร์ (บันทึกและใช้โครงร่างตัวกรองกับแผ่นงานอื่น ๆ ); การเรียงลำดับขั้นสูง ตามเดือน / สัปดาห์ / วันความถี่และอื่น ๆ ตัวกรองพิเศษ โดยตัวหนาตัวเอียง ...
  • รวมสมุดงานและแผ่นงาน; ผสานตารางตามคอลัมน์สำคัญ แยกข้อมูลออกเป็นหลายแผ่น; Batch แปลง xls, xlsx และ PDF...
  • คุณสมบัติที่ทรงพลังมากกว่า 300 รายการ. รองรับ Office/Excel 2007-2021 และ 365 รองรับทุกภาษา ง่ายต่อการปรับใช้ในองค์กรหรือองค์กรของคุณ คุณสมบัติเต็มรูปแบบ ทดลองใช้ฟรี 30 วัน รับประกันคืนเงินภายใน 60 วัน
kte แท็บ 201905

แท็บ Office นำอินเทอร์เฟซแบบแท็บมาที่ Office และทำให้งานของคุณง่ายขึ้นมาก

  • เปิดใช้งานการแก้ไขและอ่านแบบแท็บใน Word, Excel, PowerPoint, ผู้จัดพิมพ์, Access, Visio และโครงการ
  • เปิดและสร้างเอกสารหลายรายการในแท็บใหม่ของหน้าต่างเดียวกันแทนที่จะเป็นในหน้าต่างใหม่
  • เพิ่มประสิทธิภาพการทำงานของคุณ 50% และลดการคลิกเมาส์หลายร้อยครั้งให้คุณทุกวัน!
ด้านล่าง officetab
จัดเรียงความคิดเห็นโดย
ความคิดเห็น (16)
ยังไม่มีการให้คะแนน เป็นคนแรกที่ให้คะแนน!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
คุณจะดำเนินการนี้ด้วยรูปร่างต่างๆ ได้อย่างไร โดยขึ้นอยู่กับเซลล์ที่ต่างกัน
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียน คุณหยก
บทความได้รับการอัปเดตด้วยส่วนโค้ดใหม่ ซึ่งสามารถช่วยให้คุณดำเนินการกับรูปร่างต่างๆ ได้หลายแบบ โดยขึ้นอยู่กับแต่ละเซลล์ ขอบคุณสำหรับความคิดเห็นของคุณ.

ขอแสดงความนับถือที่ดีที่สุด
คริสตัล
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ฉันจะตั้งชื่อรูปร่างของฉันได้อย่างไร ในตัวอย่างด้านบน คุณจะกำหนดชื่อวงรี 2 ให้กับวงกลมที่คุณวาดได้อย่างไร
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียน คุณรังจิต
สำหรับการตั้งชื่อรูปร่าง โปรดเลือกรูปร่างนี้ ป้อนชื่อรูปร่างลงในช่องชื่อ จากนั้นกดปุ่ม Enter ดูภาพด้านล่างที่แสดง
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี ฉันจะทำซ้ำสำหรับรูปร่างหลายรูปที่เชื่อมโยงกับหลายเซลล์ในโมดูลเดียวกันได้อย่างไร
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียน คุณอภิญญา
บทความได้รับการอัปเดตด้วยส่วนโค้ดใหม่ ซึ่งสามารถช่วยให้คุณดำเนินการกับรูปร่างต่างๆ ได้หลายแบบ โดยขึ้นอยู่กับแต่ละเซลล์ ขอบคุณสำหรับความคิดเห็นของคุณ.

ขอแสดงความนับถือที่ดีที่สุด
คริสตัล
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี
ฉันได้ลองใช้โพสต์ของคุณเพื่อเขียนโค้ด VBA ของตัวเองแล้ว แต่ดูเหมือนว่าจะไปได้ไม่ไกลนัก ส่วนใหญ่เป็นเพราะฉันไม่เข้าใจ VBA จริงๆ และฉันแค่พยายามจะปรับให้เข้ากับคุณ ฉันสงสัยว่าคุณสามารถช่วยได้ไหม ฉันต้องการเปลี่ยนความยาวของสี่เหลี่ยมผืนผ้าขึ้นอยู่กับค่าในเซลล์ ฉันต้องการความกว้างหากสี่เหลี่ยมผืนผ้ายังคงเหมือนเดิม แต่ความยาวจะเปลี่ยน ผมอยากให้จุดยอดมือซ้ายทั้งสองอยู่ที่เดิมและขยายไปทางขวา เป็นไปได้ไหม
ขอขอบคุณ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
แลนที่รัก
หวังว่ารหัส VBA ต่อไปนี้สามารถแก้ปัญหาของคุณได้ (โปรดแทนที่วงรี 1 ด้วยชื่อรูปร่างของคุณเอง)

Worksheet_Change ย่อยส่วนตัว (เป้าหมายเป็นช่วง ByVal)
เกี่ยวกับข้อผิดพลาดต่อไป
ถ้า Target.Row = 2 และ Target.Column = 1 แล้ว
Call SizeCircle("วงรี 1", Val(Target.Value))
End If
ย่อยสิ้นสุด
Sub SizeCircle (ชื่อเป็นสตริง, เส้นผ่านศูนย์กลาง)
Dim xCircle เป็นรูปร่าง
Dim xDiameter เป็นโสด
เกี่ยวกับข้อผิดพลาด GoTo ExitSub
xDiameter = เส้นผ่านศูนย์กลาง
ถ้า xDiameter > 10 แล้ว xDiameter = 10
ถ้า xDiameter < 1 แล้ว xDiameter = 1
ตั้งค่า xCircle = ActiveSheet.Shapes (ชื่อ)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
ด้วย xCircle
.LockAspectRatio = msoFalse
.ความกว้าง = Application.CentimetersToPoints(xDiameter)
จบด้วย
ทางออกย่อย:
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี มีวิธีใดบ้างที่ฉันจะทำให้รูปร่างขยายออกเป็นสองมิติ (แทนที่จะเพิ่มขนาดรูปร่างขึ้น 5 ให้เพิ่ม 5 ในแนวนอนและ 3 ในแนวตั้ง)
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียน คุณแซม
สคริปต์ VBA ต่อไปนี้สามารถช่วยคุณแก้ปัญหาได้ และสองมิติคือเซลล์ A1 และ B1

Worksheet_Change ย่อยส่วนตัว (เป้าหมายเป็นช่วง ByVal)
เกี่ยวกับข้อผิดพลาดต่อไป
ถ้า Target.Count = 1 แล้ว
ถ้าไม่ตัดกัน(เป้าหมาย, ช่วง("A1:B1")) ก็ไม่มีอะไรทั้งนั้น
Call SizeCircle("วงรี 2", Array(Val(Range("A1")).Value), Val(Range("B1")).Value)))
End If
End If
ย่อยสิ้นสุด
Sub SizeCircle (ชื่อเป็นสตริง, Arr เป็นตัวแปร)
หรี่ฉันนาน
Dim xCenterX เป็นโสด
Dim xCenterY เป็นโสด
Dim xCircle เป็นรูปร่าง
เกี่ยวกับข้อผิดพลาด GoTo ExitSub
สำหรับฉัน = 0 ถึง UBound(Arr)
ถ้า Arr(I) > 10 แล้ว
อาร์ (I) = 10
ElseIf Arr(I) < 1 แล้ว
อาร์ (I) = 1
End If
ต่อไป
ตั้งค่า xCircle = ActiveSheet.Shapes (ชื่อ)
ด้วย xCircle
xCenterX = .ซ้าย + (.ความกว้าง / 2)
xCenterY = .Top + (.Height / 2)
.ความกว้าง = Application.CentimetersToPoints(Arr(0))
.ความสูง = Application.CentimetersToPoints(Arr(1))
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.ความสูง / 2)
จบด้วย
ทางออกย่อย:
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
มีวิธีการทำเช่นนี้กับรูปภาพหรือไม่? ฉันดูเหมือนจะไม่มีโชคในการใช้รหัสตามที่โพสต์

5 รูปภาพในลีดเดอร์บอร์ด ฉันต้องการให้รูปภาพในอันดับที่ 1 หรืออันดับที่ 1 มีขนาดใหญ่ขึ้น ดังนั้นฉันจึงมีขนาดรูปภาพคงที่ 2 ขนาด คือ 1x2 สำหรับไม่ใช่อันดับแรก หรือ 2x4 สำหรับอันดับที่ 1 (ตัวอย่าง) ฉันได้ตั้งค่าการจัดอันดับไว้แล้ว เพื่อใช้สร้างขนาดในเซลล์เฉพาะสำหรับแต่ละรูปภาพ (เช่น ใช้คำสั่ง IF ดังนั้น IF RANK คือขนาดที่ 1 ความกว้างคือ 2) VBA ของฉันค่อนข้างอ่อนแอ

โดยทั่วไปฉันต้องการ - ในการอัปเดตแผ่นงาน - ดูเซลล์ขนาดรูปภาพและตั้งค่าขนาดรูปภาพแต่ละขนาดให้เป็นผลลัพธ์ของเซลล์ขนาดรูปภาพที่ระบุ ฉันไม่เห็นใน VBA ด้านบนว่ามันทำงานอย่างไร แต่ฉันคิดว่ามันน่าจะง่าย!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีคริสตัล

ฉันอยากจะถามคุณว่ามีวิธีเลือกสี (เซลล์สีแดง = แบบฟอร์มสีแดง) และชื่อจากเซลล์เฉพาะหรือไม่ เป็นไปได้ไหมที่จะสร้างแบบฟอร์มโดยอัตโนมัติจาก VBA

ขอบคุณมากล่วงหน้า :)

ร้องเพลงสรรเสริญ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีคริสตัล
จะเกิดอะไรขึ้นหากกำหนดด้านของลูกบาศก์ สามเหลี่ยม กล่องที่ต้องพิจารณาตามความยาว ความกว้าง? โปรดช่วยฉันด้วย

ขอขอบคุณ
เชอริล
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีครับคุณชัยริล
ขอโทษที่ยังช่วยคุณไม่ได้ ขอบคุณสำหรับความคิดเห็นของคุณ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
มีวิธีการทำงานนี้หรือไม่หากเซลล์ที่คุณใช้ในการตั้งค่าขนาดเป็นผลมาจากสูตรมากกว่าแค่ค่าคงที่ที่คุณป้อนด้วยตนเอง
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี mathnz โค้ด VBA ด้านล่างสามารถช่วยคุณแก้ปัญหาได้ คุณเพียงแค่ต้องเปลี่ยนเซลล์ค่าและชื่อรูปร่างในโค้ดตามข้อมูลของคุณเอง
แผ่นงานย่อยส่วนตัว_Calculate()
'ปรับปรุงโดย Extendoffice 20211105
เกี่ยวกับข้อผิดพลาดต่อไป
Call SizeCircle("วงรี 1", Val(Range("A1").Value)) 'A1 คือเซลล์ค่า วงรี 1 คือชื่อรูปร่าง
Call SizeCircle("หน้ายิ้ม 2", Val(ช่วง("A2").Value))
โทร SizeCircle("Heart 3", Val(Range("A3").Value))

ย่อยสิ้นสุด
Worksheet_Change ย่อยส่วนตัว (เป้าหมายเป็นช่วง ByVal)
Dim xAddress เป็นสตริง
เกี่ยวกับข้อผิดพลาดต่อไป
ถ้า Target.CountLarge = 1 แล้ว
xAddress = Target.Address(0, 0)
ถ้า xAddress = "A1" แล้ว
Call SizeCircle("วงรี 1", Val(Target.Value))
ElseIf xAddress = "A2" จากนั้น
Call SizeCircle("หน้ายิ้ม 2", Val(Target.Value))
ElseIf xAddress = "A3" จากนั้น
โทร SizeCircle("Heart 3", Val(Target.Value))

End If
End If
ย่อยสิ้นสุด

Sub SizeCircle (ชื่อเป็นสตริง, เส้นผ่านศูนย์กลาง)
Dim xCenterX เป็นโสด
Dim xCenterY เป็นโสด
Dim xCircle เป็นรูปร่าง
Dim xDiameter เป็นโสด
เกี่ยวกับข้อผิดพลาด GoTo ExitSub
xDiameter = เส้นผ่านศูนย์กลาง
ถ้า xDiameter > 10 แล้ว xDiameter = 10
ถ้า xDiameter < 1 แล้ว xDiameter = 1
ตั้งค่า xCircle = ActiveSheet.Shapes (ชื่อ)
ด้วย xCircle
xCenterX = .ซ้าย + (.ความกว้าง / 2)
xCenterY = .Top + (.Height / 2)
.ความกว้าง = Application.CentimetersToPoints(xDiameter)
.ความสูง = Application.CentimetersToPoints(xDiameter)
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.ความสูง / 2)
จบด้วย
ทางออกย่อย:
ย่อยสิ้นสุด

มีความคิดเห็นยังไม่มีการโพสต์ที่นี่
แสดงความคิดเห็นของคุณ
โพสต์ในฐานะแขก
×
ให้คะแนนโพสต์นี้:
0   ตัวอักษร
สถานที่แนะนำ

ช่องทางอื่นๆ

ลิขสิทธิ์© 2009 - wwwextendoffice.com | สงวนลิขสิทธิ์. ขับเคลื่อนโดย ExtendOffice. | แผนผังเว็บไซต์
Microsoft และโลโก้ Office เป็นเครื่องหมายการค้าหรือเครื่องหมายการค้าจดทะเบียนของ Microsoft Corporation ในสหรัฐอเมริกาและ / หรือประเทศอื่น ๆ
ได้รับการปกป้องโดย Sectigo SSL