• DİKKAT

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

Makro ile. Koşula göre font rengi.

Merhaba Ömer Bey.

"aa","bb","cc" ve "Takip" sayfaları dışında tüm sayfalarda çalışsın istiyorsunuz doğru mu?
Evet Doğru. Bu şekilde istiyorum.

Sayfa aktif olduğunda mı?
Sayfalar gün boyu aktif vaziyette zaten.
Bunları günlük hatta saatlik üretim rapoları olarak düşünebiliriz.
Takip safasına vardiya şartını girdiğinizde mi?
Size bu kısım yansımadı. Ben vardiyaları: Vardiya 1, Vardiya 2 ..... diye farklı kitaplara aldım. Vardiyalar sabit olacak yani.
Tek bir sayfadan buton yardımıyla mı?
Yok hayır.

Peki çalışma durumu hangi şartlar da gerçekleşsin?
Ben düzineleri girdikçe renklensin istiyorum. Sürekli çalışıyor olsun yani.
 
ThisWorkbook bölümüne kopyalayın.

Kod: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 
    Dim Renk1(), Renk2(), Renk3(), Veri(), a As Byte, b As Byte, s As Byte
    Dim St As Worksheet, alan As Range, art As Integer, syf()
    
    Set alan = Range("B4:B14,F4:F14,L4:L14")
    Set St = Sheets("Takip")
    
    If Intersect(Target, alan) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
 
    syf = Array("aa", "bb", "cc", "Takip") 'istenmeyen sayfa adları
    s = 0
    On Error Resume Next
    s = WorksheetFunction.Match(ActiveSheet.Name, _
        WorksheetFunction.Transpose(syf), 0)
    If s > 0 Then: Exit Sub
        
    Veri = Array("aa", "bb", "cc", "dd", "ee", "gg")
    Renk1 = Array(41, 1, 6, 3, 50, 2)
    Renk2 = Array(53, 11, 41, 1, 3, 50)
    Renk3 = Array(22, 2, 11, 22, 11, 22)
    art = 2
    
    If Target.Column = 12 Then art = -2
    Target.Offset(0, art).Font.ColorIndex = 0
    
    If Target <> "" Then
        a = 0
        On Error Resume Next
        a = WorksheetFunction.Match(Target, _
            WorksheetFunction.Transpose(Veri), 0)
        On Error GoTo 0
        If a > 0 Then
            If St.Range("A1") = "Vardiya 1" Then
                b = Renk1(a - 1)
            ElseIf St.Range("A1") = "Vardiya 2" Then
                b = Renk2(a - 1)
            ElseIf St.Range("A1") = "Vardiya 3" Then
                b = Renk3(a - 1)
            End If
        Else
            b = 0
            MsgBox Target & "-- Değerini Bulamadım"
        End If
        Target.Offset(0, art).Font.ColorIndex = b
    End If
    
End Sub
 
Merhaba Ömer Bey.

Kodu test ettim kod gayet muntazam çalışıyor ellerinize sağlık.
Hiçbir müdahalede bulunmamak için kodu butonsuz istedim.
Lakin buton kullanmadığımız zaman sorun çıkartacak gibi gözüküyor.
İlgili alanda verileri hazır olan bir dosyaya uygulandığında verilerin üzerinden
tekrardan geçmek gerekiyor. Ona keza yapıştırma yolu ile gelen verilerde
de sıkıntı oluyor. Sizi çok meşğul ettiğimin farkındayım. Lütfen mazur görünüz.

Kodu butonla tetikleyecek hale getirebilirseniz çok sevinirim.
Thisworkbook, herhangi bir sayfa yada modül olabilir farketmez.
(Kodda herhangi bir problem yok)

Saygılarımla.
 
Module kopyalayıp deneyin.

Kod: 
Sub Renk()
 
    Dim Renk1(), Renk2(), Renk3(), Veri(), syf(), a As Byte, b As Byte, s As Byte
    Dim St As Worksheet, alan As Range, hucre As Range, art As Integer
 
    Set St = Sheets("Takip")
 
    Application.ScreenUpdating = False
 
    Set alan = Range("B4:B14,F4:F14,L4:L14")
    alan.Offset(0, 2).Font.ColorIndex = 0
    Range("J4:J14").Font.ColorIndex = 0
 
    syf = Array("aa", "bb", "cc", "Takip") 'istenmeyen sayfa adları
    Veri = Array("aa", "bb", "cc", "dd", "ee", "gg")
    Renk1 = Array(41, 1, 6, 3, 50, 2)
    Renk2 = Array(53, 11, 41, 1, 3, 50)
    Renk3 = Array(22, 2, 11, 22, 11, 22)
    art = 2
    
    s = 0
    On Error Resume Next
    s = WorksheetFunction.Match(ActiveSheet.Name, _
        WorksheetFunction.Transpose(syf), 0)
    If s > 0 Then: Exit Sub
    
    For Each hucre In alan
        If hucre <> "" Then
            a = 0
            On Error Resume Next
            a = WorksheetFunction.Match(hucre, _
                WorksheetFunction.Transpose(Veri), 0)
            On Error GoTo 0
            If a > 0 Then
                If St.Range("A1") = "Vardiya 1" Then
                    b = Renk1(a - 1)
                ElseIf St.Range("A1") = "Vardiya 2" Then
                    b = Renk2(a - 1)
                ElseIf St.Range("A1") = "Vardiya 3" Then
                    b = Renk3(a - 1)
                End If
            Else
                b = 0
                MsgBox hucre & "-- Değerini Bulamadım"
            End If
            If hucre.Column = 12 Then art = -2
            hucre.Offset(0, art).Font.ColorIndex = b
        End If
    Next hucre
 
End Sub
 
Çok çok teşekkür ederim
Ömer Bey.
Elinize yüreğinize sağlık.
Herşey gönlünüzce olsun inşallah.
Saygılarımla.
 
Merhaba Ömer Bey.
Makromuzda sonradan farkettiğim küçük bir sorun var.
Çalışma alanı genişledikçe ortaya çıktı.
Ekli dosyada izah ettim (Makro modülde) müsait zamanınızda
bakabilirseniz eğer sevinirim.
 

Ekli dosyalar

Sorunuzu anlayamadm. Daha detaylı açıklarmısınız.
 
Ömer Bey.
26 Nolu mesajdaki Örnek dosya için yazıyorum.
Modüldeki kodu çalıştırdığınız zaman sizde göreceksinizdir.
H ve J sütunları renklenmesini istediğim sütunlar.
Ve renkleniyor sorun yok.


N sütunundaki verileri (siyah haricinde herhangi bir renk yapın)
Makroyu çalıştırdığınız zaman H ve J sütunları renkleniyor iken;
N sütunundaki verilerde siyah renge dönüşüyor (Excel Orjinal rengi)

Benim isteğim makro çalıştığında N sütunundaki verilerin rengi değişmesin.
Mavi ise mavi kırmızı ise kırmızı yeşil ise yeşil kalsın.
 
Kodlardaki,

alan.Offset(0, 2).Font.ColorIndex = 0
Range("J4:J14").Font.ColorIndex = 0

Bu iki satırı silerseniz eski renkler silinmez.

.
 
Söylediklerinizi yaptım ve sorun düzeldi.
Çok çok teşekkür ederim Ömer Bey.

Saygılarımla.
 
Merhabalar Ömer Hocam.

Makromuza küçük bir ilave yapmak istedim lakin muaffak olamadım.
Tasarladığınız kod ekli dosyadaki modülde mevcut şayet müsait zamanınızda
bakabilirseniz çok sevinirim.

Saygılarımla.
 

Ekli dosyalar

Merhaba,

Değişen değer ve bölümü kırmızı ile işaretledim.

Kod: 
Sub Renk()
 
    Dim Renk1(), Renk2(), Renk3(), Veri(), syf(), a As Byte, b As Byte, s As Byte
    Dim St As Worksheet, alan As Range, hucre As Range, art As Integer
 
    Set St = Sheets("Takip")
 
    Application.ScreenUpdating = False
 
    Set alan = Range("F4:F14,O4:O14")
    syf = Array("aa", "bb", "cc", "Takip") 'istenmeyen sayfa adları
    Veri = Array("aa", "bb", "cc", "dd", "ee", "gg")
    Renk1 = Array(41, 1, 6, 3, 50, 2)
    Renk2 = Array(53, 11, 41, 1, 3, 50)
    Renk3 = Array(22, 2, 11, 22, 11, 22)
    art = 2
 
    s = 0
    On Error Resume Next
    s = WorksheetFunction.Match(ActiveSheet.Name, _
        WorksheetFunction.Transpose(syf), 0)
    If s > 0 Then: Exit Sub
 
    For Each hucre In alan
        If hucre <> "" Then
            a = 0
            On Error Resume Next
            a = WorksheetFunction.Match(hucre, _
                WorksheetFunction.Transpose(Veri), 0)
            On Error GoTo 0
            If a > 0 Then
                If St.Range("A1") = "Vardiya 1" Then
                    b = Renk1(a - 1)
                ElseIf St.Range("A1") = "Vardiya 2" Then
                    b = Renk2(a - 1)
                ElseIf St.Range("A1") = "Vardiya 3" Then
                    b = Renk3(a - 1)
                End If
            Else
                b = 0
                MsgBox hucre & "-- Değerini Bulamadım"
            End If
            If hucre.Column = 15 Then art = [COLOR=red]-3[/COLOR]
            hucre.Offset(0, art).[COLOR=red]Resize(, 2).[/COLOR]Font.ColorIndex = b
        End If
    Next hucre
 
End Sub

.
 
Çok çok teşekkür ediyorum.
Ömer Hocam.
Elinize zihninize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst