• DİKKAT

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

ÇÖZÜLDÜ Hücre değerine göre Nesne Biçimlendirme

E

excellkurdu

Katılım
16 Nisan 2008
Mesajlar
313
Excel Vers. ve Dili
Türkçe Microsoft Office Excel 2007
Merhaba Arkadaşlar,
Hücre değerine göre şekil biçimlendirmesi yapabilir miyiz? Çok aradım benzeri daha önce yapılmamış sanırım. Sayfa2 de sorunlu yazının solundaki numarayı, sayfa1 de olan şeklin içindeki numara eşini bularak kırmızı dolgu yaptırabilir miyiz?
Saygılarımla
 

Ekli dosyalar

Son düzenleme:
Merhaba.
Alt taraftan şekillerin olduğu sayfanın adına (Sayfa1) fareyle sağ tıkladığınızda açılan menüden
KOD GÖRÜNTÜLEyi seçin açılan VBA ekranında sağ taraftaki boş alana aşağıdaki kod'u yapıştırın.
Kod Sayfa1'e geçtiğinizde kendiliğinden çalışacaktır.
.
Kod: 
[B][COLOR="blue"][FONT="Trebuchet MS"]Private Sub Worksheet_Activate()[/COLOR][/B]
Dim ss1 As Worksheet: Set ss1 = Sheets("Sayfa1")
Dim ss2 As Worksheet: Set ss2 = Sheets("Sayfa2")[SIZE="1"]
[/SIZE]    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual[SIZE="1"]
[/SIZE]For dd = 1 To 6 [B][COLOR="SeaGreen"]'***>>şekil sayısı[/COLOR][/B]
    ActiveSheet.Shapes.Range(Array(dd & " Dikdörtgen")).Select
    Selection.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
Next[SIZE="1"]

[/SIZE]For a = 4 To ss2.[D65536].End(3).Row
    If ss2.Cells(a, 4) = "sorunlu" Then
        aranan = ss2.Cells(a, 2)
            For sekil = 1 To 6 [B][COLOR="SeaGreen"]'***>>şekil sayısı[/COLOR][/B]
                ActiveSheet.Shapes.Range(Array(sekil & " Dikdörtgen")).Select
                metin = Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text
                    If metin = aranan Then
                        Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
                    Else: GoTo 10
                    End If
10:        Next
    Else
        aranan = ""
    End If
Next
ss1.Cells(1, 1).Activate
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True[SIZE="1"]
[/SIZE]MsgBox "ŞEKİLLER BOYANDI"[SIZE="1"]
[/SIZE][B][COLOR="blue"]End Sub[/COLOR][/B][/FONT]
 
Son düzenleme:
Ömer Hocam çok sağolun. Diktörtgen şekillerde çalıştı. yıldız, küp ve silindir şekillerde çalıştıramadım. Diktörtgen yazan yeri mi değitirmem gerek?
 
Merhaba.
Kod'u aşağıdaki ile değiştirirseniz, sayfadaki tüm çizim nesneleri için kullanılabilir.
Nesnedeki metne göre boyama yapılır.
Kod: 
[FONT="Trebuchet MS"][B][COLOR="blue"]Private Sub Worksheet_Activate()[/COLOR][/B]
Dim ss2 As Worksheet: Set ss2 = Sheets("Sayfa2")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
ActiveSheet.DrawingObjects.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
For a = 4 To ss2.[D65536].End(3).Row
    If ss2.Cells(a, 4) = "sorunlu" Then
        aranan = ss2.Cells(a, 2)
            For sekil = 1 To ActiveSheet.DrawingObjects.Count
                ActiveSheet.Shapes.Range(Array(sekil)).Select
                metin = Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text
                    If metin = aranan Then
                        Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
                    Else: GoTo 10
                    End If
10:        Next
    End If
Next: Cells(1, 1).Activate
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
[B][COLOR="Blue"]End Sub[/COLOR][/B][/FONT]
 
Son düzenleme:
Hocam az şekilli sayfalarda çalışıyor. Fakat bu sefer de çok şekilli sayfalarda donma oldu. Sizi her defasında yormaktansa dosyaya bakarsanız sevinirim.


omer.baran' Alıntı:
Merhaba.
Kod'u aşağıdaki ile değiştirirseniz, sayfadaki tüm çizim nesneleri için kullanılabilir.
Nesnedeki metne göre boyama yapılır.
Kod: 
[FONT="Trebuchet MS"][B][COLOR="blue"]Private Sub Worksheet_Activate()[/COLOR][/B]
Dim ss2 As Worksheet: Set ss2 = Sheets("Sayfa2")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
ActiveSheet.DrawingObjects.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
For a = 4 To ss2.[D65536].End(3).Row
    If ss2.Cells(a, 4) = "sorunlu" Then
        aranan = ss2.Cells(a, 2)
            For sekil = 1 To ActiveSheet.DrawingObjects.Count
                ActiveSheet.Shapes.Range(Array(sekil)).Select
                metin = Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text
                    If metin = aranan Then
                        Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
                    Else: GoTo 10
                    End If
10:        Next
    End If
Next: Cells(1, 1).Activate
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
[B][COLOR="Blue"]End Sub[/COLOR][/B][/FONT]
Genişletmek için tıkla ...
 

Ekli dosyalar

Belge ekte.

Eğer DÜĞME kullanmak yerine KOD'un, Veri sayfasında C sütunundaki değerlerde değişiklik
yapıldığında otomatik olarak çalışmasını isterseniz (C sütununa verilerin elle yazıldığını varsayarak);

Alt Tarafta VERİ sayfasının adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin
ve açılan VBA ekranında sağ taraftaki boş alana aşağıdaki KODu yapıştırın.
Eğer bunu tercih ederseniz kullanım kolaylığı bakımından, Module1'deki
KOD'un sondan bir önceki satırında yer alan MsgBox satırını silmenizde yarar var.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C4:C" & [B65536].End(3).Row)) Is Nothing Then Exit Sub
Call ŞEKİL_BOYA_BARAN
End Sub

Bu arada profilinizde excel versiyonu için 2007 yazmışsınız ama eklediğiniz belge sonraki versiyon.
Profilinizdeki Excel Versiyonunuzu düzeltmelisiniz.
.
 

Ekli dosyalar

Son düzenleme:
Hocam her şey güzel sadece BOYA dediğimiz zaman Veri sayfasının B sütününda adı olmayan şekilleri MAVİ renge çeviriyor. Bu sefer değişmesini istemediğim şekiller de MAVİ renk alıyor. Dİğer yaptıklarınız tam istediğim gibi olmuş, çok sağolun.
 
excellkurdu' Alıntı:
Hocam her şey güzel sadece BOYA dediğimiz zaman Veri sayfasının B sütününda adı olmayan şekilleri MAVİ renge çeviriyor. Bu sefer değişmesini istemediğim şekiller de MAVİ renk alıyor. Dİğer yaptıklarınız tam istediğim gibi olmuş, çok sağolun.
Genişletmek için tıkla ...

İstisna şekiller belli ise onları yoksayması için kod'a ilave yapmayı denerim.
Aklıma gelen en pratik çözüm;
istisna şekillerin adlarını ve bulunduğu sayfayı bir alana (Veri sayfasında olması sanırım daha uygun olur) listelemek
ve oradan kontrol için bir satırlık kod ilavesiyle hallolması lazım sanki.

Eklenen şeklin adını/türünü, şekil seçildiğinde; formül çubuğunun sol tarafındaki alanda görebilirsiniz.
 
Son düzenleme:
omer.baran' Alıntı:
İstisna şekiller belli ise onları yoksayması için kod'a ilave yapmayı denerim.
Aklıma gelen en pratik çözüm;
istisna şekillerin adlarını ve bulunduğu sayfayı bir alana (Veri sayfasında olması sanırım daha uygun olur) listelemek
ve oradan kontrol için bir satırlık kod ilavesiyle hallolması lazım sanki.

Eklenen şeklin adını/türünü, şekil seçildiğinde; formül çubuğunun sol tarafındaki alanda görebilirsiniz.
Genişletmek için tıkla ...

Şekiller çok değişkenlik gösterebiliyor. Bu tamamen bina durumuna bağlı ve her müşteri için farklı proje şekil çizilmekte. Biz bu projeleri müşteriden hazır alıp üzerlerine renklenmesini istediğim gözlem noktaları koyuyoruz. Aylık olarak hangi gözlem noktasında aktivasyon varsa o noktaları kırmızı göstererek müşteriye veriyoruz. Yok sayması, sadece B sutununa göre boyaması çok güzel olacak. Olmasa da yinede çok sağolsun Hocam.
 
Tekrar merhaba.
Mevcut kod'u (Modüle1'de) aşağıdaki ile değiştirerek dener misiniz?

Deneme öncesi B sütunuyla ilgisi olmayan şekilleri farklı renge boyayınız ki farkı görebilin.

Kod: 
Sub ŞEKİL_BOYA_BARAN()
Dim v As Worksheet: Set v = Sheets("Veri")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For Each sayfa In Worksheets
        If sayfa.Name = "Veri" Then
            GoTo 20
        End If
        sayfa.Activate
            sayı = sayfa.DrawingObjects.Count
                For sekil = 1 To sayı
                    sayfa.Shapes.Range(Array(sekil)).Select
                        metin = Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text
                            If metin = "" Or _
                                WorksheetFunction.CountIf(v.Range("B4:B" & v.[B65536].End(3).Row), metin) = 0 Then
                                GoTo 10
                            Else
                            Selection.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
                            satır = WorksheetFunction.Match(metin, v.Range("B1:B" & v.[B65536].End(3).Row), 0)
                                If v.Cells(satır, 4) = "sorunlu" Then
                                    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
                                Else: GoTo 10
                                End If
                            End If
10:             Next
sayfa.Cells(1, 1).Activate
20:  Next
v.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub
 
Maalesef sorun devam ediyor. İlgisi olmayanlar MAVİ renk oldu.
 
Hocam sorun gitti. Harika çalışıyor. Allah binlerce kez razı olsun. Şu renklendirme en az 2 günümü alıyordu. Tekrar sağolasın.
 
omer.baran' Alıntı:
Tekrar merhaba.
Mevcut kod'u (Modüle1'de) aşağıdaki ile değiştirerek dener misiniz?

Deneme öncesi B sütunuyla ilgisi olmayan şekilleri farklı renge boyayınız ki farkı görebilin.
Genişletmek için tıkla ...
Hocam sorun gitti. Harika çalışıyor. Allah binlerce kez razı olsun. Şu renklendirme en az 2 günümü alıyordu. Tekrar sağolasın.
 
excellkurdu' Alıntı:
Hocam sorun gitti. Harika çalışıyor. Allah binlerce kez razı olsun. Şu renklendirme en az 2 günümü alıyordu. Tekrar sağolasın.
Genişletmek için tıkla ...

Estağfurullah efendim, ihtiyaç görüldüyse mesele yok.

Trabzon'a selam olsun.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst