dikdörtgene sığdırma

[acar6783]

Kolay gelsin arkadaşlar
ekteki dosyada dikdörtgen kutu içerisine bir hücreyi eşitledim.
bu hücre içerisine girdiğim veri değişiyor sürekli ve her değişen veriye göre dikdörgenin içindeki verinin de otomatik boyutlanmasını istiyorum. yani otomatik sığmasını bunu nasıl başarabilrim?

 

[Murat OSMA]

Ek'te dosya yok.

 

[acar6783]

dosya eklendi.problem olmuş sanırım

 

[Murat OSMA]

Fark ettim.


Şekil üzerinde sağ tıklayın, Şekil Biçimlendirden Metin Kutusunu seçin ve Şekli metin sığacak şekilde boyutlandırı seçin.

 

[acar6783]

)
hocam şekil metine değil, metin şekile göre sığacak bunu bulamadım ?

 

[acar6783]

Bulamıyacakmıyız?

 

[Murat OSMA]

Çok mu acil ? :dusun:

Sayfanın kod kısmına kodları yapıştırıp deneyin...

Şimdilik makro ile şöyle basit bir çözüm aklıma geliyor;

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "J3" Then Exit Sub
    If Len(Target.Value) = 1 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350
    ElseIf Len(Target.Value) = 2 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350 / 3
    ElseIf Len(Target.Value) = 3 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350 / 6
    ElseIf Len(Target.Value) = 4 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350 / 12
    ElseIf Len(Target.Value) = 5 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350 / 16
    ElseIf Len(Target.Value) = 6 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350 / 22
    ElseIf Len(Target.Value) = 7 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350 / 28
    ElseIf Len(Target.Value) > 7 Then
        ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = Len(Target.Value) * 350 / 40
    End If
End Sub

 

[acar6783]

[COLOR="Yellow"]    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select[/COLOR]

bu satırda hata veriyor belirtilen değer bulunamadı şeklinde

 

[acar6783]

hatayı buldum dikdörtgen 1 yazan yeri "Rectangle 1" olarak yazılmış kodda
ben mevcut dosyadaki dikdörtgen 1 ismini başka birşeyşe değiştirdim ve koddaki yeri de onunla değiştirdim bu sefer kod çalıştı
fakat sorun şu ki koddaki listeyi sanırım j3 e yazacağımız her verinin harf sayısına kadar çoğaltmamız gerekecek..

başka bir yolu yok mudur?

 

[acar6783]

evet arkadaşlar bir çözüm önerisi olan var mı?

 

[acar6783]

bu konuyla ilgili yardımcı olabilecek kimse yok mu?