Girilen değere göre hücredeki şeklin görünür hale gelmesi

ynmcan · 2 Kasım 2021

Merhaba arkadaşlar;
Uzun bir açıklama olacak kusura bakmayın. Yardımcı olacak olan tüm arkadaşlara şimdiden teşekkür ederim

Ekteki dosyada; Kan şekeri değerlerini girdiğim tüm hücrelerde değerlere göre görünür hale gelen 5 ayrı şekil var ( sağdaki çizelgede görüldüğü gibi )
Sağdaki çizelgedeki şekil isimleri tüm hücrelerde aynı ( NormalDeğer 1, OrtaDüşükDeğer 1, OrtaYüksekDeğer 1, AşırıDüşükDeğer 1, AşırıYüksekDeğer 1 )
sağdaki çizelgedeki hücrelerdeki şekillerin adlar aynı olduğu için kopyala yapıştır olarak kolay şekilde yerleştirdim ve aktif hücreye girilen değer göre aktif hücredeki ilgili şeklin görünür hale gelmesi diğerlerinin ise gizlenmesi için aşağıdaki kodu yazdım.

-----------------------------------------------------------------------------
sat=ActiveCell.Row
sut=ActiveCell.Column
If Cells(sat, sut) >= 90 And Cells(sat, sut) <= 160 Then
ActiveSheet.Shapes.Range(Array("NormalDeğer " & sut & sat)).Visible = msoTrue
ActiveSheet.Shapes.Range(Array("OrtaDüşükDeğer " & sut & sat)).Visible = msoFalse
ActiveSheet.Shapes.Range(Array("OrtaYüksekDeğer " & sut & sat)).Visible = msoFalse
ActiveSheet.Shapes.Range(Array("AşırıDüşükDeğer " & sut & sat)).Visible = msoFalse
ActiveSheet.Shapes.Range(Array("AşırıYüksekDeğer " & sut & sat)).Visible = msoFalse
End If -----------------------------------------------------------------------------

Ancak kod aktif hücredeki şekli değil, her seferinde ilk kopyalama yaptığım "R10" hücredeki şekil görünür hale getiriyor.

Bundan dolayı soldaki çizelgeye şekillerin adlarını hücre sütun ve satır değerlerinin birleşmesinden oluşan adlar ile değiştirdim
( Örnek olarak;"D10" hücresindeki şekil adları 4. sütun 10. satırın birleşimi 410 olduğundan, NormalDeğer 410, OrtaDüşükDeğer 410, OrtaYüksekDeğer 410, AşırıDüşükDeğer 410, AşırıYüksekDeğer 410 şeklinde değiştirdim )
Ancak bu işlem çok uğraştırdığı için şu anda iki satırı yapabildim.
Kodun sat, sut değişkenini değiştirerek aşağıdaki şekilde yazdım

-----------------------------------------------------------------------------
For sut = 4 To 14
For sat = 10 To 24
If Cells(sat, sut) >= 90 And Cells(sat, sut) <= 160 Then
On Error Resume Next
ActiveSheet.Shapes.Range(Array("NormalDeğer " & sut & sat)).Visible = msoTrue
ActiveSheet.Shapes.Range(Array("OrtaDüşükDeğer " & sut & sat)).Visible = msoFalse
ActiveSheet.Shapes.Range(Array("OrtaYüksekDeğer " & sut & sat)).Visible = msoFalse
ActiveSheet.Shapes.Range(Array("AşırıDüşükDeğer " & sut & sat)).Visible = msoFalse
ActiveSheet.Shapes.Range(Array("AşırıYüksekDeğer " & sut & sat)).Visible = msoFalse
End If
next sat
next sut
-----------------------------------------------------------------------------

Ancak bu kod tüm hücreleri dolanarak değerlendirdiği için yavaş çalışıyor.
( Ayrıca şekil adlarını da tüm hücrelere göre yeniden adlandırmakta zor bir iş )

Yukarıdaki açıklamalarıma göre bu işlemi daha kısa ve hızlı yapabilecek bir koda ihtiyacım var
(şekiller aynı kalması şartı ile, aynı işlemi yapacak Fonksiyon yada koşullu biçimlendirmede olabilir.)

ÖmerFaruk · 2 Kasım 2021

Kod yerine
Simge+Formül+KoşulluBiçimlendirme ile yaptığım örneği inceleyin.
Ne kodları ne exceli bunun için yormayın derim.

Ekran görüntüsü ve dosya ektedir.

ynmcan · 2 Kasım 2021

Teşekkür ederim ÖmerFaruk bey.
Verdiğiniz örneği kendi dosyama uyarladım. sorunsuz şekilde çalışıyor.
Ama ben yine de ilk yolladığım dosyadaki aynı hücrede verilerin üzerinde görülen şekiller üzerinde çalışmaya devam ediyorum

İyi bir sonuç elde edemezsem sizin çözümünüzü kullanıcam.

ÖmerFaruk · 2 Kasım 2021

Kodları düzeltseniz dahi düzgün bir şekilde hücredeki rakamlarla üst üste örtüştemeyeceksiniz. Bazı rakamlar okumayacak, bazıları okunacak.

Her durumda tercih sizindir.
Kolay gelsin.

1mak1mak · 3 Kasım 2021

ÖmerFaruk' Alıntı:
Kod yerine
Simge+Formül+KoşulluBiçimlendirme ile yaptığım örneği inceleyin.
Ne kodları ne exceli bunun için yormayın derim.

Ekran görüntüsü ve dosya ektedir.
Ekli dosyayı görüntüle 231394

Ömer Hocam merhaba
Bende UNICHAR çalışmadı DAMGA ile şekiller oluyor ama reklendirme için.
Rica etsem Koşulda Renklendirmek için kullandığınız Formülleri paylaşabilirmisiniz.
Dosyada Koşullar gözükmüyor.
Şimdiden Teşekkürler

1mak1mak · 3 Kasım 2021

Hocam
Tek koşul formülü gibi düşünüp sordum ama daha sonra 5 ayrı koşul formülü girdim ancak Yeşil diğer değerlerle kesişiyor.
Yeşili göstermiyor.

Kod:

=YADA(D10>90; D10<160)

ÖmerFaruk · 3 Kasım 2021

Dosyanın kendisi orada zaten.
Aradığınız tüm formüller iaşretlerin olduğu sütünlarda ve bunlarla ilgili koşullu biçimlendirmelerde.
Simgelerin olduğu hücrede yazı tipi renkgini kırmızı yaparsanız simge de kırmızı olur.

1mak1mak · 3 Kasım 2021

ÖmerFaruk' Alıntı:
Dosyanın kendisi orada zaten.
Aradığınız tüm formüller iaşretlerin olduğu sütünlarda ve bunlarla ilgili koşullu biçimlendirmelerde.
Simgelerin olduğu hücrede yazı tipi renkgini kırmızı yaparsanız simge de kırmızı olur.

Hocam o Formüllerle denedim ama yapamadım sürüklediğimde hep aynı renk oluyor.
ayrıca son mesajınızın üstündeki mesajıma bir ilave soru ekledim ilgilenmeniz mümkünmü.

ynmcan · 3 Kasım 2021

ÖmerFaruk' Alıntı:
Kodları düzeltseniz dahi düzgün bir şekilde hücredeki rakamlarla üst üste örtüştemeyeceksiniz. Bazı rakamlar okumayacak, bazıları okunacak.

Her durumda tercih sizindir.
Kolay gelsin.

Aslında belli bir aşamaya geldim. tek bir sorun kaldı.
kodlar aktif hücre Left -Top değerlerine göre çalıştığından, hücreye değeri yazıldığım an makroyu tetikleyecek bir işlem gerekiyor (entere basmak veya değeri yazdığım hücreden başka bir hücreye tıklamak gibi ) ancak bu işlemi yapınca değer yazdığım aktif hücreden çıktığım için kod çalışmıyor. tekrar değer yazdığım hücreye geri gelmem gerekiyor veya değer yazdığım hücreye gelip buton yardımıyla makroyu çalıştırıyorum.

Hücreye değeri yazarken veya yazdıktan sonra hücreden ayrılmadan ( hücrenin aktifliğini koruyarak ) makroyu çalıştıracak ( buton harici ) bir işlem bulamadım.

Korhan Ayhan · 3 Kasım 2021

Sayfa kodunu aşağıdaki gibi değiştiriniz.

C++:

Private Sub Worksheet_Change(ByVal Target As Range)
    Makro3 Range(Target.Address)
End Sub

Makro3 kodunu aşağıdaki gibi değiştiriniz.

C++:

Sub Makro3(Hucre As Range)

    Dim cRange As Range
    Set cRange = Hucre
    
    Dim dLeft As Double, dTop As Double
    
    dLeft = cRange.Left
    dTop = cRange.Top
'-------------------------------------------------------------------------------------------------
sayfayıKorumasınıAç
'-------------------------------------------------------------------------------------------------
 On Error Resume Next
    ActiveSheet.Shapes.Range(Array("NormalDeğer " & dLeft & dTop)).Delete
    ActiveSheet.Shapes.Range(Array("OrtaDüşükDeğer " & dLeft & dTop)).Delete
    ActiveSheet.Shapes.Range(Array("OrtaYüksekDeğer " & dLeft & dTop)).Delete
    ActiveSheet.Shapes.Range(Array("AşırıDüşükDeğer " & dLeft & dTop)).Delete
    ActiveSheet.Shapes.Range(Array("AşırıYüksekDeğer " & dLeft & dTop)).Delete
    
'-------------------------------------------------------------------------------------------------

'-------------------------------------------------------------------------------------------------
If cRange >= 90 And cRange <= 160 Then

On Error Resume Next
        ActiveSheet.Shapes.AddShape(msoShapeDiamond, dLeft, dTop, 48, 30).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(146, 208, 80)
        .Transparency = 0.6
        .Solid
    End With
    Selection.Name = "NormalDeğer " & dLeft & dTop
    Selection.OnAction = "Makro7"
End If
'-------------------------------------------------------------------------------------------------

'-------------------------------------------------------------------------------------------------
If cRange >= 70 And cRange <= 89 Then
    
On Error Resume Next
        ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, dLeft, dTop, 48, 30).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 192, 0)
        .Transparency = 0.6
        .Solid
    End With
    Selection.ShapeRange.Rotation = 180
    Selection.Name = "OrtaDüşükDeğer " & dLeft & dTop
    Selection.OnAction = "Makro7"
End If
'-------------------------------------------------------------------------------------------------

'-------------------------------------------------------------------------------------------------
If cRange >= 161 And cRange <= 180 Then
    
On Error Resume Next
        ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, dLeft, dTop, 48, 30).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 192, 0)
        .Transparency = 0.6
        .Solid
    End With
    Selection.Name = "OrtaYüksekDeğer " & dLeft & dTop
    Selection.OnAction = "Makro7"
End If
'-------------------------------------------------------------------------------------------------

'-------------------------------------------------------------------------------------------------
If cRange > 1 And cRange < 70 Then

On Error Resume Next
        ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, dLeft, dTop, 48, 30).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0.8
        .Solid
    End With
    Selection.ShapeRange.Rotation = 180
    Selection.Name = "AşırıDüşükDeğer " & dLeft & dTop
    Selection.OnAction = "Makro7"
End If
'-------------------------------------------------------------------------------------------------

'-------------------------------------------------------------------------------------------------
If cRange > 180 Then

On Error Resume Next
        ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, dLeft, dTop, 48, 30).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ShapeRange.IncrementRotation 180
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0.8
        .Solid
    End With
    Selection.Name = "AşırıYüksekDeğer " & dLeft & dTop
    Selection.OnAction = "Makro7"
End If
'-------------------------------------------------------------------------------------------------
sayfayıKoru
'-------------------------------------------------------------------------------------------------

End Sub

ynmcan · 3 Kasım 2021

Teşekkür ederim Korhan Bey sağ olun.
Dosyamın son hali ekte

1mak1mak · 4 Kasım 2021

Merhaba
Bende Şeker hastasıyım bazen şekeri bu şekilde takip ediyorum lazım olur diye ilgilendim.
Ömer hocanın yolu çok hızlı çalışıyor ama renklendirmede sorun yaşadım değerlerin başlangıç ve bitiş değerlerini renklendirmedi.
Aşağıdaki koşulları formül olarak kullandım ama resimde de görüldüğü gibi siyah kalıyor renklenmiyor.

Kod:

=D10<70  (Kırmızı)
=VE(D10>70; D10<89)  (Sarı)
=VE(D10>90; D10<160)  (Yeşil)
=VE(D10>160; D10<180)  (Sarı)
=D10>180  (Kırmızı)

ÖmerFaruk · 4 Kasım 2021

=VE(D10>=90; D10<160)
90'eşit ya da büyük 160dan küçük ise yeşil yapar.
Sizinkinde 90 dan büyük 160dan küçükse yeşil yapıyor.

Formülü kendi aralıklarınıza göre
> / >= / < / <= gibi uygun karşılaştırma ifadelerinden faydalanmalısınız.

1mak1mak · 4 Kasım 2021

ÖmerFaruk' Alıntı:
=VE(D10>=90; D10<160)
90'eşit ya da büyük 160dan küçük ise yeşil yapar.
Sizinkinde 90 dan büyük 160dan küçükse yeşil yapıyor.

Formülü kendi aralıklarınıza göre
> / >= / < / <= gibi uygun karşılaştırma ifadelerinden faydalanmalısınız.

Sağolasınız Ömer hocam
Haklısınız söylediğiniz şekilde düzeldi esasında daha önce biliyordum ama nasılsa kafam çalışmadı.
Teşekkür ederim.

Girilen değere göre hücredeki şeklin görünür hale gelmesi

ynmcan

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

Ekli dosyalar

ynmcan

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

1mak1mak

1mak1mak

ÖmerFaruk

Destek Ekibi

1mak1mak

ynmcan

Ekli dosyalar

Korhan Ayhan

Administrator

ynmcan

Ekli dosyalar

1mak1mak

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

1mak1mak