• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

  • Konbuyu başlatan Konbuyu başlatan ynmcan
  • Başlangıç tarihi Başlangıç tarihi
ynmcan

ynmcan

Katılım
30 Ağustos 2008
Mesajlar
677
Excel Vers. ve Dili
2010 türkçe
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.)
 

Ekli dosyalar

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.
231394
 

Ekli dosyalar

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.
 

Ekli dosyalar

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.
 
Ö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
Genişletmek için tıkla ...
Ö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
 
Son düzenleme:
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)
 
Son düzenleme:
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.
 
Ö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.
Genişletmek için tıkla ...
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ü.
 
Ö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.
Genişletmek için tıkla ...
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.
 

Ekli dosyalar

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
 
Teşekkür ederim Korhan Bey sağ olun.
Dosyamın son hali ekte
 

Ekli dosyalar

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ı)
 

Ekli dosyalar

  • 04-11-2021 00-56-28.jpg
    04-11-2021 00-56-28.jpg
    165.7 KB · Görüntüleme: 5
=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.
 
Ö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.
Genişletmek için tıkla ...
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst