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

Excel'de belirtilen hücre değerine dayalı / bağlı olarak şekil boyutunu otomatik olarak nasıl değiştirebilirim?

Şekil boyutunu belirli bir hücrenin değerine göre otomatik olarak değiştirmek istiyorsanız, bu makale size yardımcı olabilir.

VBA kodu ile belirtilen hücre değerine göre şekil boyutunu otomatik değiştir


VBA kodu ile belirtilen hücre değerine göre şekil boyutunu otomatik değiştir

Aşağıdaki VBA kodu, geçerli çalışma sayfasındaki belirtilen hücre değerine göre belirli bir şekil boyutunu değiştirmenize yardımcı olabilir. Lütfen aşağıdaki işlemleri yapın.

1. Boyutunu değiştirmeniz gereken şekli içeren sayfa sekmesine sağ tıklayın ve ardından Kodu Görüntüle sağ tıklama menüsünden.

2. içinde Uygulamalar için Microsoft Visual Basic penceresinde, aşağıdaki VBA kodunu Kod penceresine kopyalayıp yapıştırın.

VBA kodu: Excel'de belirtilen hücre değerine göre otomatik şekil boyutunu değiştir

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

not: Kodda, "Oval 2"Boyutunu değiştireceğiniz şeklin adıdır. Ve Satır = 2, Sütun = 1 "Oval 2" şeklinin boyutunun A2'deki değerle değiştirileceği anlamına gelir. Lütfen ihtiyaç duyduğunuzda değiştirin.

Farklı hücre değerlerine göre birden çok şekli otomatik olarak yeniden boyutlandırmak için lütfen aşağıdaki VBA kodunu uygulayın.

VBA kodu: Excel'de belirtilen farklı hücrelerin değerine göre birden çok şekli otomatik olarak yeniden boyutlandırın

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

Notlar:

1) Kodda, "Oval 1""Gülen Yüz 3"Ve"Kalp 3”, Boyutlarını otomatik olarak değiştireceğiniz şekillerin adıdır. Ve A1, A2 veA3 Şekilleri temel alarak otomatik olarak yeniden boyutlandıracağınız hücrelerdir.
2) Daha fazla şekil eklemek istiyorsanız, lütfen çizgi ekleyin "ElseIf xAddress = "A3" O halde" ve "Call SizeCircle (" Heart 2 ", Val (Hedef.Value))"ilkinin üstünde"Eğer son"koddaki satır. Ve ihtiyaçlarınıza göre hücre adresini ve şekil adını değiştirin.

3. Basın Ara Toplam + Q kapatmak için aynı anda tuşları Uygulamalar için Microsoft Visual Basic pencere.

Şu andan itibaren, A2 hücresindeki değeri değiştirdiğinizde, Oval 2 şeklinin boyutu otomatik olarak değişecektir. Ekran görüntüsüne bakın:

Veya karşılık gelen "Oval 1", "Gülen Yüz 2" ve "Kalp 3" şekillerini otomatik olarak yeniden boyutlandırmak için A1, A3 ve A3 hücresindeki değerleri değiştirin. Ekran görüntüsüne bakın:

not: Hücre değeri 10'dan büyük olduğunda şekil boyutu artık değişmeyecektir.


Geçerli Excel çalışma kitabındaki tüm şekilleri listeleyin ve dışa aktarın:

The Grafikleri Dışa Aktar yarar Kutools for Excel mevcut çalışma kitabındaki tüm şekilleri hızlı bir şekilde listelemenize yardımcı olur ve hepsini aşağıdaki ekran görüntüsü shwon gibi tek seferde belirli bir klasöre aktarabilirsiniz. Şimdi indirin ve deneyin! (30- günlük ücretsiz iz)


İlgili yazılar:


En İyi Ofis Üretkenliği Araçları

Kutools for Excel Sorunlarınızın Çoğunu Çözer ve Verimliliğinizi% 80 Artırır

  • Yeniden: Hızlıca yerleştirin karmaşık formüller, grafikler ve daha önce kullandığınız her şey; Hücreleri Şifrele şifre ile; Posta Listesi Oluşturun ve e-posta gönder ...
  • Süper Formül Çubuğu (birden çok metin ve formül satırını kolayca düzenleyin); Okuma Düzeni (çok sayıda hücreyi kolayca okuyun ve düzenleyin); Filtrelenmiş Aralığa Yapıştır...
  • Hücreleri / Satırları / Sütunları Birleştirme Veri kaybetmeden; Bölünmüş Hücre İçeriği; Yinelenen Satırları / Sütunları Birleştirme... Yinelenen Hücreleri Önleyin; Aralıkları Karşılaştır...
  • Yinelenen veya Benzersiz'i seçin Satırlar; Boş Satırları Seçin (tüm hücreler boştur); Süper Bul ve Bulanık Bul Birçok Çalışma Kitabında; Rastgele Seçim ...
  • Tam kopya Formül referansını değiştirmeden Birden Çok Hücre; Otomatik Referans Oluştur Birden Çok Sayfaya; Madde İşaretleri Ekle, Onay Kutuları ve daha fazlası ...
  • Metni Çıkar, Metin Ekle, Konuma Göre Kaldır, Alanı Kaldır; Sayfalama Alt Toplamları Oluşturma ve Yazdırma; Hücre İçeriği ve Yorumları Arasında Dönüştür...
  • Süper Filtre (filtre şemalarını kaydedin ve diğer sayfalara uygulayın); Gelişmiş Sıralama ay / hafta / gün, sıklık ve daha fazlasına göre; Özel Filtre kalın, italik ...
  • Çalışma Kitaplarını ve Çalışma Sayfalarını Birleştirin; Tabloları anahtar sütunlara göre birleştirin; Verileri Birden Çok Sayfaya Bölme; Toplu dönüştürme xls, xlsx ve PDF...
  • 300'den fazla güçlü özellik. Office / Excel 2007-2021 ve 365'i destekler. Tüm dilleri destekler. Kuruluşunuzda veya kuruluşunuzda kolay devreye alma. Tam özellikler 30 günlük ücretsiz deneme. 60 günlük para iade garantisi.
kte sekmesi 201905

Office Tab, Office'e Sekmeli Arayüz Getirir ve İşinizi Çok Daha Kolay Hale Getirir

  • Word, Excel, PowerPoint'te sekmeli düzenlemeyi ve okumayı etkinleştirin, Publisher, Access, Visio ve Project.
  • Yeni pencereler yerine aynı pencerenin yeni sekmelerinde birden çok belge açın ve oluşturun.
  • Üretkenliğinizi% 50 artırır ve her gün sizin için yüzlerce fare tıklamasını azaltır!
ofis tabanı
Yorumları sıralama ölçütü
Yorumlar (16)
Henüz derecelendirme yok. İlk değerlendiren siz olun!
Bu yorum sitedeki moderatör tarafından en aza indirildi
Bunu, her biri farklı hücrelere bağlı olarak birden fazla şekille nasıl uygularsınız?
Bu yorum sitedeki moderatör tarafından en aza indirildi
Sevgili Yeşim,
Makale, her biri farklı hücrelere bağlı olarak birden çok şekil ile yürütmenize yardımcı olabilecek yeni bir kod bölümü ile güncellendi. Yorumun için teşekkür ederim.

Saygılarımla,
Kristal
Bu yorum sitedeki moderatör tarafından en aza indirildi
Şeklimi nasıl adlandırırım? Yukarıdaki örnekte çizdiğiniz daireye Oval 2 ismini nasıl veriyorsunuz?
Bu yorum sitedeki moderatör tarafından en aza indirildi
Sevgili Ranjit,
Bir şekle isim vermek için lütfen bu şekli seçin, şekil adını İsim Kutusuna girin ve ardından Enter tuşuna basın. Aşağıda gösterilen resme bakın.
Bu yorum sitedeki moderatör tarafından en aza indirildi
Merhaba, aynı modüldeki birden çok hücreye bağlı birden çok şekil için aynı şeyi nasıl çoğaltırım?
Bu yorum sitedeki moderatör tarafından en aza indirildi
Sevgili Abhinaya,
Makale, her biri farklı hücrelere bağlı olarak birden çok şekil ile yürütmenize yardımcı olabilecek yeni bir kod bölümü ile güncellendi. Yorumun için teşekkür ederim.

Saygılarımla,
Kristal
Bu yorum sitedeki moderatör tarafından en aza indirildi
Merhaba,
Gönderinizi kendi VBA kodumu yazmak için kullanmaya çalıştım ama çok uzağa gitmiyor gibi görünüyor. Esas olarak VBA'yı gerçekten anlamıyorum ve sadece sizinkini uyarlamaya çalışıyorum. Yardım edip edemeyeceğinizi merak ediyordum. Bir hücredeki değere bağlı olarak bir dikdörtgenin uzunluğunu değiştirmek istiyorum. Dikdörtgenin aynı kalmasını, ancak uzunluğunun değişmesini genişliğini istiyorum. Her iki sol köşenin de aynı yerde kalmasını ve sağa doğru uzamasını istiyorum. Mümkün mü?
teşekkür ederim
Bu yorum sitedeki moderatör tarafından en aza indirildi
sevgili lan,
Aşağıdaki VBA kodunun sorununuzu çözebileceğini umuyoruz. (Lütfen Oval 1'i kendi şekil adınızla değiştirin)

Özel Alt Çalışma Alanı_Değiştir (ByVal Target As Range)
On Error Resume Next
Target.Row = 2 Ve Target.Column = 1 ise
SizeCircle("Oval 1", Val(Target.Value)) çağırın
Eğer son
End Sub
Sub SizeCircle(Dize Olarak Ad, Çap)
Şekil Olarak Dim xCircle
Dim xÇap Tekli
Hatada GoTo ExitSub
xÇap = Çap
xÇap > 10 ise, xÇap = 10
xÇap < 1 ise, xÇap = 1
xCircle = ActiveSheet.Shapes(Ad) ayarla
xCircle.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
xCircle ile
.LockAspectRatio = msoFalse
.Width = Application.CentimeterToPoints(xDiameter)
İle bitmek
ExitSub:
End Sub
Bu yorum sitedeki moderatör tarafından en aza indirildi
Merhaba, şekli iki boyutta genişletebilmemin bir yolu var mı (şekil boyutunu 5 artırmak yerine yatayda 5, dikeyde 3 artırın)?
Bu yorum sitedeki moderatör tarafından en aza indirildi
Sevgili Sam,
Aşağıdaki VBA betiği sorunu çözmenize yardımcı olabilir. Ve iki boyut, A1 ve B1 hücresidir.

Özel Alt Çalışma Alanı_Değiştir (ByVal Target As Range)
On Error Resume Next
Target.Count = 1 ise
Kesişmiyorsa(Hedef, Aralık("A1:B1")) O Zaman Hiçbir Şey Değildir
SizeCircle("Oval 2", Array(Değer(Range("A1").Value), Val(Range("B1").Value))) çağırın
Eğer son
Eğer son
End Sub
Sub SizeCircle(Dize Olarak Ad, Varyant Olarak Arr)
Dim kadar uzun
Dim xCenterX Tek Olarak
Dim xCenterY Tek Kişilik
Şekil Olarak Dim xCircle
Hatada GoTo ExitSub
I = 0 için UBound(Arr) için
Arr(I) > 10 ise
Dizi(I) = 10
ElseIf Arr(I) < 1 O zaman
Dizi(I) = 1
Eğer son
Sonraki
xCircle = ActiveSheet.Shapes(Ad) ayarla
xCircle ile
xCenterX = .Sol + (.Genişlik / 2)
xCenterY = .Üst + (.Yükseklik / 2)
.Width = Application.CentimeterToPoints(Arr(0))
.Height = Application.CentimeterToPoints(Arr(1))
.Sol = xCenterX - (.Genişlik / 2)
.Üst = xCenterY - (.Yükseklik / 2)
İle bitmek
ExitSub:
End Sub
Bu yorum sitedeki moderatör tarafından en aza indirildi
Bunu Görüntüler ile yapmanın bir yolu var mı? Gönderildiği gibi kodu kullanma şansım yok gibi görünüyor.

Bir lider panosundaki 5 Resim, 1.'deki veya 1.'ye bağlanan Görsellerin daha büyük olmasını istiyorum. Bu nedenle, 2 sabit görüntü boyutum var, ya birinci olmayanlar için 1x2 ya da 2. sıradakiler için 4x1 (örneğin). Sıralamamı zaten ayarladım, bu yüzden bunu her görüntü için belirli hücrelerde boyutlar oluşturmak için kullanabilirim (yani bir IF ifadesi kullanın, böylece IF RANK 1. boyut genişliği 2'dir). VBA'm olsa da oldukça zayıf.

Temel olarak - sayfa güncellemesinde - görüntü boyutu hücrelerine bakmak ve her görüntü boyutunu belirli görüntü boyutu hücreleri sonucuna göre ayarlamak istiyorum. Yukarıdaki VBA'da bunun tam olarak nasıl çalıştığını göremiyorum ama bence kolay olmalı!
Bu yorum sitedeki moderatör tarafından en aza indirildi
Merhaba Crytal,

Belirli hücrelerden renk (kırmızı hücre = kırmızı form) ve isim seçmenin bir yolu olup olmadığını sormak istiyorum. VBA'dan otomatik olarak formlar oluşturmak da mümkün olabilir mi?

Şimdiden çok teşekkür ederim :)

ilahi
Bu yorum sitedeki moderatör tarafından en aza indirildi
Merhaba Crytal
Peki ya uzunluğuna, genişliğine göre belirlenmesi gereken küpün, üçgenin, kutunun bir kenarı belirlenirse? Lütfen bana yardım et

Teşekkür ederim
sandalye
Bu yorum sitedeki moderatör tarafından en aza indirildi
Merhaba Başkan,
Maalesef henüz bu konuda size yardımcı olamam. Yorumun için teşekkürler.
Bu yorum sitedeki moderatör tarafından en aza indirildi
Boyutu ayarlamak için kullandığınız hücre, manuel olarak girdiğiniz statik bir değer yerine bir formülün sonucuysa, bunun çalışmasının bir yolu var mı?
Bu yorum sitedeki moderatör tarafından en aza indirildi
Merhaba matematik, Aşağıdaki VBA kodu sorunu çözmenize yardımcı olabilir. Koddaki değer hücrelerini ve şekil adlarını kendi verilerinize göre değiştirmeniz yeterlidir.
Özel Alt Çalışma Sayfası_Hesapla()
'Tarafından güncellendi Extendoffice 20211105
On Error Resume Next
SizeCircle("Oval 1", Val(Range("A1").Value)) çağırın 'A1 değer hücresidir, Oval 1 şekil adıdır
SizeCircle("Smiley Face 2", Val(Range("A2").Value)) arayın
SizeCircle("Kalp 3", Val(Range("A3").Value)) çağırın

End Sub
Özel Alt Çalışma Alanı_Değiştir (ByVal Target As Range)
Dize Olarak xAddress Dim
On Error Resume Next
Target.CountLarge = 1 ise
xAdres = Hedef.Adres(0, 0)
xAddress = "A1" ise
SizeCircle("Oval 1", Val(Target.Value)) çağırın
ElseIf xAddress = "A2" O halde
SizeCircle("Smiley Face 2", Val(Target.Value)) arayın
ElseIf xAddress = "A3" O halde
SizeCircle("Kalp 3", Val(Target.Value)) çağırın

Eğer son
Eğer son
End Sub

Sub SizeCircle(Dize Olarak Ad, Çap)
Dim xCenterX Tek Olarak
Dim xCenterY Tek Kişilik
Şekil Olarak Dim xCircle
Dim xÇap Tekli
Hatada GoTo ExitSub
xÇap = Çap
xÇap > 10 ise, xÇap = 10
xÇap < 1 ise, xÇap = 1
xCircle = ActiveSheet.Shapes(Ad) ayarla
xCircle ile
xCenterX = .Sol + (.Genişlik / 2)
xCenterY = .Üst + (.Yükseklik / 2)
.Width = Application.CentimeterToPoints(xDiameter)
.Height = Application.CentimeterToPoints(xDiameter)
.Sol = xCenterX - (.Genişlik / 2)
.Üst = xCenterY - (.Yükseklik / 2)
İle bitmek
ExitSub:
End Sub

Buraya henüz hiç yorum yapılmamış
Lütfen yorum yazın
Misafir olarak yayınlama
×
Bu gönderiyi değerlendirin:
0   Karakterler
Önerilen Konumlar

Bizi takip et

Telif Hakkı © 2009 - www.extendoffice.com. | Tüm hakları Saklıdır. Tarafından desteklenmektedir ExtendOffice. | | | Site Haritası
Microsoft ve Office logosu, Microsoft Corporation'ın Amerika Birleşik Devletleri ve / veya diğer ülkelerdeki ticari markaları veya tescilli ticari markalarıdır.
Sectigo SSL ile korunmaktadır