Note: The other languages of the website are Google-translated. Back to English
English English
  • Documents
  • Excel
  • Bagaimana cara mengubah ukuran bentuk secara otomatis berdasarkan / bergantung pada nilai sel yang ditentukan di Excel?

Bagaimana cara mengubah ukuran bentuk secara otomatis berdasarkan / bergantung pada nilai sel yang ditentukan di Excel?

Jika Anda ingin mengubah ukuran bentuk secara otomatis berdasarkan nilai sel yang ditentukan, artikel ini dapat membantu Anda.

Ubah ukuran bentuk secara otomatis berdasarkan nilai sel yang ditentukan dengan kode VBA


Ubah ukuran bentuk secara otomatis berdasarkan nilai sel yang ditentukan dengan kode VBA

Kode VBA berikut dapat membantu Anda mengubah ukuran bentuk tertentu berdasarkan nilai sel yang ditentukan di lembar kerja saat ini. Silakan lakukan sebagai berikut.

1. Klik kanan tab lembar dengan bentuk yang perlu Anda ubah ukurannya, lalu klik Lihat kode dari menu klik kanan.

2. Dalam Microsoft Visual Basic untuk Aplikasi jendela, salin dan tempel kode VBA berikut ke jendela Kode.

Kode VBA: Ubah ukuran bentuk secara otomatis berdasarkan nilai sel yang ditentukan di 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

Note: Di kode, "2 oval”Adalah nama bentuk yang ukurannya akan diubah. Dan Baris = 2, Kolom = 1 artinya ukuran shape “Oval 2” akan berubah dengan nilai A2. Harap ubah sesuai kebutuhan Anda.

Untuk mengubah ukuran berbagai bentuk secara otomatis berdasarkan nilai sel yang berbeda, harap terapkan kode VBA di bawah ini.

Kode VBA: Secara otomatis mengubah ukuran berbagai bentuk berdasarkan nilai sel tertentu yang berbeda di 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

Catatan:

1) Di kode, "1 oval","Wajah Tersenyum 3"Dan"Jantung 3”Adalah nama bentuk yang ukurannya akan diubah secara otomatis. Dan A1, A2 sertaA3 adalah sel yang nilai bentuknya akan otomatis diubah ukurannya.
2) Jika Anda ingin menambahkan lebih banyak bentuk, tambahkan garis "ElseIf xAddress = "A3" Lalu"dan "Call SizeCircle (" Heart 2 ", Val (Target.Value))"di atas yang pertama"End If"di dalam kode. Dan ubah alamat sel dan nama bentuk berdasarkan kebutuhan Anda.

3. tekan lain + Q tombol secara bersamaan untuk menutup Microsoft Visual Basic untuk Aplikasi jendela.

Mulai sekarang, saat Anda mengubah nilai di sel A2, ukuran bentuk Oval 2 akan diubah secara otomatis. Lihat tangkapan layar:

Atau ubah nilai di sel A1, A2 dan A3 untuk mengubah ukuran bentuk yang sesuai "Oval 1", "Smiley Face 3" dan "Heart 3" secara otomatis. Lihat tangkapan layar:

Note: Ukuran bentuk tidak akan lagi berubah jika nilai sel lebih besar dari 10.


Buat daftar dan ekspor semua bentuk di buku kerja Excel saat ini:

The Ekspor Grafik kegunaan Kutools untuk Excel membantu Anda dengan cepat mencantumkan semua bentuk dalam buku kerja saat ini, dan Anda dapat mengekspor semuanya ke folder tertentu sekaligus seperti gambar di bawah ini. Unduh dan coba sekarang! (

- jalur bebas hari)


Artikel terkait:


Alat Produktivitas Kantor Terbaik

Kutools for Excel Memecahkan Sebagian Besar Masalah Anda, dan Meningkatkan Produktivitas Anda dengan
80%

  • Reuse: Masukkan dengan cepat rumus, bagan yang kompleks dan apa pun yang pernah Anda gunakan sebelumnya; Enkripsi Sel dengan kata sandi; Buat Milis dan mengirim email ...
  • Bilah Formula Super (dengan mudah mengedit beberapa baris teks dan rumus); Membaca Tata Letak (membaca dan mengedit sel dalam jumlah besar dengan mudah); Tempel ke Rentang yang Difilter...
  • Gabungkan Sel / Baris / Kolom tanpa kehilangan Data; Pisahkan Konten Sel; Gabungkan Baris / Kolom Duplikat... Mencegah Sel Duplikat; Bandingkan Rentang...
  • Pilih Duplikat atau Unik Baris; Pilih Baris Kosong (semua sel kosong); Temukan Super dan Temukan Fuzzy di Banyak Buku Kerja; Pilih Acak ...
  • Salinan Tepat Beberapa Sel tanpa mengubah referensi rumus; Buat Referensi Otomatis ke Beberapa Lembar; Sisipkan Poin, Kotak Centang, dan lainnya ...
  • Ekstrak Teks, Tambahkan Teks, Hapus berdasarkan Posisi, Hapus Space; Membuat dan Mencetak Subtotal Paging; Konversi Konten Antar Sel dan Komentar...
  • Filter Super (simpan dan terapkan skema filter ke sheet lain); Penyortiran Lanjutan menurut bulan / minggu / hari, frekuensi dan lainnya; Filter Khusus dengan huruf tebal, miring ...
  • Gabungkan Workbooks dan WorkSheets; Gabungkan Tabel berdasarkan kolom kunci; Pisahkan Data menjadi Beberapa Lembar; Konversi Batch xls, xlsx dan PDF...
  • Lebih dari
    300
    fitur yang kuat
    . Mendukung Office/Excel
    2007-2019 dan 365
    . Mendukung semua bahasa. Penerapan yang mudah di perusahaan atau organisasi Anda. Fitur lengkap
    30
    percobaan gratis -hari. Jaminan uang kembali 60 hari.
tab kte 201905

Tab Office Membawa antarmuka Tab ke Office, dan Membuat Pekerjaan Anda Jauh Lebih Mudah

  • Aktifkan pengeditan dan pembacaan tab di Word, Excel, PowerPoint, Publisher, Access, Visio, dan Project.
  • Buka dan buat banyak dokumen di tab baru di jendela yang sama, bukan di jendela baru.
  • Meningkatkan produktivitas Anda dengan
    50%
    , dan mengurangi ratusan klik mouse untuk Anda setiap hari!
officetab bawah
Urutkan komentar berdasarkan
komentar (16)
Belum ada peringkat. Jadilah yang pertama memberi peringkat!
Komentar ini diminimalkan oleh moderator di situs
Bagaimana Anda menjalankan ini dengan beberapa bentuk masing-masing tergantung pada sel yang berbeda?
Komentar ini diminimalkan oleh moderator di situs
Jade yang terhormat,
Artikel diperbarui dengan bagian kode baru yang dapat membantu Anda mengeksekusi dengan berbagai bentuk masing-masing tergantung pada sel yang berbeda. Terima kasih atas komentarmu.

Salam Hormat,
Kristal
Komentar ini diminimalkan oleh moderator di situs
Bagaimana saya memberi nama bentuk saya? Dalam contoh Anda di atas, bagaimana Anda menetapkan nama Oval 2 pada lingkaran yang telah Anda gambar?
Komentar ini diminimalkan oleh moderator di situs
Ranjit yang terhormat,
Untuk penamaan bentuk, silahkan pilih bentuk ini, masukkan nama bentuk ke dalam Kotak Nama, lalu tekan tombol Enter. Lihat di bawah gambar yang ditampilkan.
Komentar ini diminimalkan oleh moderator di situs
Hai, bagaimana cara mereplikasi yang sama untuk beberapa bentuk yang ditautkan ke beberapa sel dalam modul yang sama?
Komentar ini diminimalkan oleh moderator di situs
Abhinaya yang terhormat,
Artikel diperbarui dengan bagian kode baru yang dapat membantu Anda mengeksekusi dengan berbagai bentuk masing-masing tergantung pada sel yang berbeda. Terima kasih atas komentarmu.

Salam Hormat,
Kristal
Komentar ini diminimalkan oleh moderator di situs
Hai,
Saya telah mencoba menggunakan posting Anda untuk menulis kode VBA saya sendiri tetapi sepertinya tidak terlalu jauh. Terutama karena saya tidak begitu mengerti VBA dan saya hanya mencoba mengadaptasi Anda. Saya ingin tahu apakah Anda bisa membantu. Saya ingin mengubah panjang persegi panjang tergantung pada nilai dalam sel. Saya ingin lebarnya jika persegi panjang tetap sama tetapi panjangnya berubah. Saya ingin kedua simpul tangan kiri tetap di tempat yang sama dan memanjang ke kanan. Apakah ini mungkin?
Terima kasih
Komentar ini diminimalkan oleh moderator di situs
sayang lan,
Semoga kode VBA berikut dapat menyelesaikan masalah Anda. (Silakan ganti Oval 1 dengan nama bentuk Anda sendiri)

Sub Lembar Kerja Pribadi_Rubah (Rentang Target As ByVal)
On Error Resume Next
Jika Target.Row = 2 Dan Target.Column = 1 Maka
Call SizeCircle("Oval 1", Val(Target.Value))
End If
End Sub
Sub Ukuran Lingkaran (Nama Sebagai String, Diameter)
Redupkan xLingkaran Sebagai Bentuk
Redupkan xDiameter Sebagai Tunggal
Pada Kesalahan GoTo ExitSub
xDiameter = Diameter
Jika xDiameter > 10 Maka xDiameter = 10
Jika xDiameter < 1 Maka xDiameter = 1
Setel xCircle = ActiveSheet.Shapes(Name)
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Dengan xLingkaran
.LockAspectRatio = msoFalse
.Lebar = Aplikasi.CentimetersToPoints(xDiameter)
Berakhir dengan
KeluarSub:
End Sub
Komentar ini diminimalkan oleh moderator di situs
Hai, apakah ada cara agar saya dapat membuat bentuk mengembang pada dua dimensi (daripada menambah ukuran bentuk sebesar 5, menambahnya 5 pada horizontal dan 3 pada vertikal)?
Komentar ini diminimalkan oleh moderator di situs
Sam sayang,
Skrip VBA berikut dapat membantu Anda memecahkan masalah. Dan dua dimensi adalah sel A1 dan B1.

Sub Lembar Kerja Pribadi_Rubah (Rentang Target As ByVal)
On Error Resume Next
Jika Target. Hitung = 1 Maka
Jika Tidak Berpotongan(Target, Rentang("A1:B1")) Tidak Berarti
Panggil SizeCircle("Oval 2", Array(Val(Range("A1").Value), Val(Range("B1").Value)))
End If
End If
End Sub
Sub SizeCircle (Nama Sebagai String, Arr Sebagai Varian)
Redup Aku Selamanya
Redupkan xCenterX Sebagai Single
Redupkan xCenterY Sebagai Single
Redupkan xLingkaran Sebagai Bentuk
Pada Kesalahan GoTo ExitSub
Untuk I = 0 Ke UBound(Arr)
Jika Arr(I) > 10 Maka
Arr(I) = 10
LainJika Arr(I) < 1 Maka
Arr(I) = 1
End If
Next
Setel xCircle = ActiveSheet.Shapes(Name)
Dengan xLingkaran
xCenterX = .Kiri + (.Lebar / 2)
xCenterY = .Atas + (.Tinggi / 2)
.Lebar = Aplikasi.CentimetersToPoints(Arr(0))
.Tinggi = Aplikasi.CentimetersToPoints(Arr(1))
.Kiri = xCenterX - (.Lebar / 2)
.Top = xCenterY - (.Tinggi / 2)
Berakhir dengan
KeluarSub:
End Sub
Komentar ini diminimalkan oleh moderator di situs
Apakah ada cara untuk melakukan ini dengan Gambar? Sepertinya saya tidak beruntung menggunakan kode seperti yang diposting.

5 Gambar di papan peringkat, saya ingin Gambar di 1 atau diikat untuk 1 menjadi lebih besar. Oleh karena itu saya telah memperbaiki 2 ukuran gambar, baik 1x2 untuk bukan yang pertama atau 2x4 untuk posisi pertama (misalnya). Saya sudah menyiapkan peringkat sehingga dapat menggunakannya untuk membuat ukuran dalam sel tertentu untuk setiap gambar (yaitu menggunakan pernyataan IF jadi IF RANK adalah lebar ukuran pertama adalah 1). VBA saya cukup lemah.

Pada dasarnya saya ingin - pada pembaruan lembar - lihat sel ukuran gambar dan atur setiap ukuran gambar ke hasil sel ukuran gambar tertentu. Saya tidak dapat melihat di VBA di atas cara kerjanya, tetapi saya pikir itu seharusnya mudah!
Komentar ini diminimalkan oleh moderator di situs
Hai Kristal,

Saya ingin bertanya kepada Anda, apakah ada cara untuk memilih warna (sel merah = bentuk merah) dan nama dari sel tertentu. apakah mungkin membuat formulir secara otomatis dari VBA?

Terima kasih banyak sebelumnya :)

Nyanyian syukur
Komentar ini diminimalkan oleh moderator di situs
hai kristal
bagaimana jika untuk menentukan sisi kubus, segitiga, kotak yang harus ditentukan berdasarkan panjang, lebar? Tolong bantu aku

Terima kasih
kursi
Komentar ini diminimalkan oleh moderator di situs
Hai Chairil,
Maaf belum bisa membantu Anda. Terima kasih atas komentar Anda.
Komentar ini diminimalkan oleh moderator di situs
apakah ada cara agar ini berfungsi jika sel yang Anda gunakan untuk mengatur ukuran adalah hasil dari formula dan bukan hanya nilai statis yang Anda masukkan secara manual?
Komentar ini diminimalkan oleh moderator di situs
Hai mathnz,Kode VBA di bawah ini dapat membantu Anda memecahkan masalah. Anda hanya perlu mengubah sel nilai dan nama bentuk dalam kode berdasarkan data Anda sendiri.
Sub Worksheet_Calculate() Pribadi
'Diperbaharui oleh Extendoffice 20211105
On Error Resume Next
Call SizeCircle("Oval 1", Val(Range("A1").Value)) 'A1 adalah sel nilai, Oval 1 adalah nama bentuk
Ukuran PanggilanCircle("Wajah Tersenyum 2", Val(Rentang("A2").Nilai))
Ukuran PanggilanCircle("Hati 3", Val(Rentang("A3").Nilai))

End Sub
Sub Lembar Kerja Pribadi_Rubah (Rentang Target As ByVal)
Redupkan xAlamat Sebagai String
On Error Resume Next
Jika Target.CountLarge = 1 Kemudian
xAlamat = Target.Alamat(0, 0)
Jika xAddress = "A1" Maka
Call SizeCircle("Oval 1", Val(Target.Value))
ElseIf xAddress = "A2" Lalu
Ukuran PanggilanCircle("Wajah Tersenyum 2", Val(Target.Nilai))
ElseIf xAddress = "A3" Lalu
Ukuran PanggilanCircle("Hati 3", Val(Target.Nilai))

End If
End If
End Sub

Sub Ukuran Lingkaran (Nama Sebagai String, Diameter)
Redupkan xCenterX Sebagai Single
Redupkan xCenterY Sebagai Single
Redupkan xLingkaran Sebagai Bentuk
Redupkan xDiameter Sebagai Tunggal
Pada Kesalahan GoTo ExitSub
xDiameter = Diameter
Jika xDiameter > 10 Maka xDiameter = 10
Jika xDiameter < 1 Maka xDiameter = 1
Setel xCircle = ActiveSheet.Shapes(Name)
Dengan xLingkaran
xCenterX = .Kiri + (.Lebar / 2)
xCenterY = .Atas + (.Tinggi / 2)
.Lebar = Aplikasi.CentimetersToPoints(xDiameter)
.Tinggi = Aplikasi.CentimetersToPoints(xDiameter)
.Kiri = xCenterX - (.Lebar / 2)
.Top = xCenterY - (.Tinggi / 2)
Berakhir dengan
KeluarSub:
End Sub

Belum ada komentar yang diposting di sini
Tinggalkan komentar anda
Posting sebagai Tamu
×
Beri peringkat pos ini:
0   Karakter
Lokasi yang Disarankan

Ikuti kami

Hak Cipta © 2009 - www.extendoffice.com. | Seluruh hak cipta. Dipersembahkan oleh ExtendOffice. | Peta Situs
Microsoft dan logo Office adalah merek dagang atau merek dagang terdaftar dari Microsoft Corporation di Amerika Serikat dan / atau negara lain.
Dilindungi oleh Sectigo SSL