ZOR BİR KOŞULLU BİÇİMLENDİRME

[idrisgul1379]

Koşullu Biçimlendirmeyle alakalı zor bir istekte bulunucam, internette çok araştırdım ama buna benzer bir örnek bulamadım. Burada çözüm sağlayabilecek kişiler vardır diye düşünüyorum. İstenenleri ve açıklamaları dosya içerisine yazdım. Yardımcı olabilirseniz çok müteşekkir olurum. Dosyayı ekliyorum

İndir YARDIM

Dosyayı indir YARDIM

dosya.co

 

[Korhan Ayhan]

Bence makro ile daha pratik olur..

 

[Korhan Ayhan]

Ek olarak;

BW2 koduna ait bitiş değeri yandaki tabloda yok. Bu durumda ne yapılacak?
BW1 koduna ait başlangıç-bitiş değerleri yandaki tabloda hiç yok. Bu durumda ne yapılacak?

 

[52779]

YARDIM.xlsx dosyasını indir - download

YARDIM.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

Eki incelersiniz...
Açıklamaları ekteki dosyada yapmaya çalıştım.

 

[idrisgul1379]

Resmen çölde bir vaha gibisiniz, çok teşekkür ederim, elleriniz dert görmesin

YARDIM.xlsx dosyasını indir - download

YARDIM.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

Eki incelersiniz...
Açıklamaları ekteki dosyada yapmaya çalıştım.

 

[idrisgul1379]

Ek olarak;

BW2 koduna ait bitiş değeri yandaki tabloda yok. Bu durumda ne yapılacak?
BW1 koduna ait başlangıç-bitiş değerleri yandaki tabloda hiç yok. Bu durumda ne yapılacak?

Korhan Bey yüklediğim dosya problemimin simüle edilmiş bir kısmıydı; anlaşılması kolay olsun diye kompleks halini yüklememiştim. Buraya yüklediğim örnek dosyada ise özellikle AX1 koduna odaklandığım için de bahsettiğiniz diğer kodlarla ilgili olan kısımlar da bazı şeyler gözden kaçmış. Sizden bir sonra yorum yapan 52779 nickname li kullanıcı problemimi gerçekten çok güzel bi şekilde çözmüş. İlgilendiğiniz için sizede çok teşekkür ederim.

 

[52779]

Resmen çölde bir vaha gibisiniz, çok teşekkür ederim, elleriniz dert görmesin

Teşekkür ediyorum...
İyi akşamlar sizlere..

 

[Korhan Ayhan]

Çözüme ulaşmanız sevindirici...

Bende hazırladığım kodu paylaşmak istedim. Belki benzer tablosu olup kullanmak isteyen olabilir.

Option Explicit

Sub Renklendir()
    Dim Aranan As String, Bul As Range, Adres As String
    Dim No_1 As Range, No_2 As Range, X As Byte, Y As Byte
    
    Application.ScreenUpdating = False
    
    With Range("K5:BS18")
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With
    
    Aranan = Range("H2").Value
    
    Set Bul = Range("C5:C18").Find(Aranan, Range("C18"), , xlWhole)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            Set No_1 = Range("K2:BS4").Find(Bul.Offset(0, 1).Text, Range("BS4"), , xlWhole)
            Set No_2 = Range("K2:BS4").Find(Bul.Offset(0, 2).Text, Range("BS4"), , xlWhole)
            
            If Not No_1 Is Nothing And Not No_2 Is Nothing Then
                For X = 5 To 17 Step 3
                    If Cells(X, "J") = Bul.Offset(0, 3).Value Then
                        For Y = No_1.Column To No_2.Column
                            Cells(X, Y).Interior.Color = 65535
                            If Cells(X, Y) = "" Then
                                Cells(X, Y).NumberFormat = "@"
                                Cells(X, Y) = Bul.Offset(0, -1).Value
                                If Cells(X + 1, Y).Interior.Color = 16777215 Then
                                    Cells(X + 1, Y).Interior.Color = 5296274
                                Else
                                    Cells(X + 1, Y).Interior.Color = 49407
                                End If
                            Else
                                Cells(X, Y) = Cells(X, Y) & "-" & Bul.Offset(0, -1).Value
                                If Cells(X + 1, Y).Interior.Color = 16777215 Then
                                    Cells(X + 1, Y).Interior.Color = 5296274
                                Else
                                    Cells(X + 1, Y).Interior.Color = 49407
                                End If
                            End If
                        Next
                        Exit For
                    End If
                Next
                Set Bul = Range("C5:C18").Find(Aranan, Bul)
            End If
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
    
    Range("K:BS").Columns.AutoFit
    
    Application.ScreenUpdating = True
        
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[idrisgul1379]

Makro yazmayı (en kötü ihtimalle kullanmayı) öğrenmem lazım sanırım