Başka yerdeki hücreyi boyayabilmem mümkün mü aynı sayfada ?

[Büşra Güzelyurt]

Merhaba,

Aslında ben bu konuyu açmıştım fakat yapılan cevaplardan arkaplanda kaldı yeninden konu açma gereği duydum.

projemde kodlar çalışıyor ve seçime göre sistem şeklilleri geliyor fakat ben başka bir aralıkta resim getirmek yada kolaysa boyamak istiyorum. Ne yapmam lazım bu kodun neresine ne eklmem lazım acaba ?

yardımınız için şimdiden teşekkürler....

Kodlar bunlar fakat bunun neresine eklenti yapmam lazım ?

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.CommandBars("Picture").Visible = False
If Intersect(Target, Range("C11:C" & [c65536].End(3).Row)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.CommandBars("Picture").Visible = False
 ActiveSheet.DrawingObjects.Delete
For U = 11 To Range("C65536").End(3).Row
    If Cells(U, "C") <> "" Then
        Resim = Left(Cells(U, "C"), 5) & " Resmi"
        Sheets("Geviss").Select
        ActiveSheet.Shapes("" & Resim & "").Select
    With Selection
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 14#
        .ShapeRange.Width = 20#
        .ShapeRange.Rotation = 0#
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 17.75
        .ShapeRange.Width = 22.5
        .ShapeRange.Rotation = 0#
            
            Sheets("Geviss").Shapes("" & Resim & "").Copy
            Sheets("Veri Girişi").Select
            Cells(U, "B").Select
            ActiveSheet.Paste
        
        Sheets("Geviss").Select
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Height = 14#
        .ShapeRange.Width = 20#
        .ShapeRange.Rotation = 0#
        Sheets("Veri Girişi").Select
    End With
    End If
Next
Cells(Target.Row, "C").Select
Application.ScreenUpdating = True
End Sub

 

[Huseyinkis]

Ekteki dosyayı incelermisiniz.

 

[Büşra Güzelyurt]

Merhaba,

Çok teşekkürler fakat sadece beyaz renk geliyor, ben diğer renklerin gelmesi için nereye eklenti yapmam gerek ? İnanın bulamadım

Next
Cells(Target.Row, "C").Select
GoTo son:
Application.ScreenUpdating = True
BBB:
For a = 1 To Range("P65536").End(3).Row
If Range("F5").Value = Cells(a, "P").Value Then
renk = Cells(a, "Q").Interior.Color * 1
Range("E5").Interior.Color = renk
End If
Next a
son:

Burayamı yazmam gerek ? tekrardan çok teşekkür ederim...

 

[Huseyinkis]

P hücresine renkleri tanımlamışsınız bende Q hücresine p hücresinde seçilen renge hücre biçimini aynı renk yapın.

Mesala P2=Altınmeşe Q2= Hücre dolgu rengini Sarı yapın. Altınmeşe seçilinde E5 sarı olacaktır.

 

[Büşra Güzelyurt]

Bu beyaza boyuyor tamam ... Sarı renk için nereye kod yazıcam inanın bulamadım

Next
Cells(Target.Row, "C").Select
GoTo son:
Application.ScreenUpdating = True
BBB:
For a = 1 To Range("P65536").End(3).Row
If Range("F5").Value = Cells(a, "P").Value Then
renk = Cells(a, "Q").Interior.Color * 1
Range("E5").Interior.Color = renk
End If
Next a
son:

Bu şekilde mi olması lazım o zamanda çalışmıyor hata veriyor.

Next
Cells(Target.Row, "C").Select
GoTo son:
Application.ScreenUpdating = True
BBB:
For a = 1 To Range("P65536").End(3).Row
If Range("F5").Value = Cells(a, "P").Value Then
renk = Cells(a, "Q").Interior.Color * 1
Range("E5").Interior.Color = renk
End If
Next a

////// Burada bu kodu kopyalıyorum ama olmuyor
Next
Cells(Target.Row, "C").Select
GoTo son:
Application.ScreenUpdating = True
BBB:
For a = 1 To Range("P65536").End(3).Row
If Range("F5").Value = Cells(a, "P2").Value Then
renk = Cells(a, "Q2").Interior.Color * 1
Range("E5").Interior.Color = renk
End If
Next a

son:

 

[Huseyinkis]

Bu beyaza boyuyor tamam ... Sarı renk için nereye kod yazıcam inanın bulamadım

Bu şekilde mi olması lazım o zamanda çalışmıyor hata veriyor.

Kodda bir değişiklik yapmıycaksınız benim yazdığım kodlar aynen kalsın. Siz "Veri Girişi" sayfasında Q1 Q2 Q3 Q4 hücrelerinin dolgı renklerini değiştirmeniz gerekiyor.

 

[Büşra Güzelyurt]

ayy çok pardon ben görmedim orayı ))...

Allah razı olsun çok çok sağolun Hüseyin bey ....

 

[Huseyinkis]

ayy çok pardon ben görmedim orayı ))...

Allah razı olsun çok çok sağolun Hüseyin bey ....

Teşekkürler.

İyi Çalışmalar.