• DİKKAT

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

Renk Kodlarına göre satır biçimlendirme

I

ismail-34

Katılım
9 Ekim 2021
Mesajlar
343
Excel Vers. ve Dili
excell 2013
Merhaba saygıdeğer hocalarım

Bunu koşullu biçimlendirmedende yapabilirim ancak mümkünse makrodaki çözümünü rica ediyorum

detay sayfasındaki f sütunundaki firma adlarının baş harfine göre satırı renklendirsin istiyorum.

bunu renk kodları sayfasındaki harfi alıp firma isminin baş harfi ile karşılaştırıp alıp uygulamasını istiyorum.

Örnek Ektedir.

Saygılar sevgiler.
 

Ekli dosyalar

Merhaba.
Detay sayfasının kod kısmına aşağıdaki kodu kopyalayın.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    If Not Intersect(Target, Range("F2:F" & Rows.Count)) Is Nothing Then
       Set Bul = Worksheets("Renk Kodları").Range("A:A").Find(what:=Left(Target.Text, 1), lookat:=xlWhole)
       Range("A" & Target.Row & ":BL" & Target.Row).Interior.Color = Bul.Offset(0, 1).Interior.Color
    End If
End Sub
 
Muzaffer Bey Sanat Eseri olmuş. Faturalarda firmaların vurgulanması açısından çok faydalı bir eser bence. Elinize Yüreğinize sağlık.

Çok Teşekkür Ederim. Sağlıcakla Kalın.
 
Muzaffer Ali' Alıntı:
Merhaba.
Detay sayfasının kod kısmına aşağıdaki kodu kopyalayın.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    If Not Intersect(Target, Range("F2:F" & Rows.Count)) Is Nothing Then
       Set Bul = Worksheets("Renk Kodları").Range("A:A").Find(what:=Left(Target.Text, 1), lookat:=xlWhole)
       Range("A" & Target.Row & ":BL" & Target.Row).Interior.Color = Bul.Offset(0, 1).Interior.Color
    End If
End Sub
Genişletmek için tıkla ...
Muzaffer Hocam Tekrar merhaba. sayfamda 2 tane Worksheet.Change li ifade olduğu için renklendirme çalışmıyor.renklendirme kodunuzu module de tıklamayla çalışacak şekilde nasıl yazabiliriz ? Sayfamdaki Option Explicit ile başlayan kodu silince renklendirme kodu anca çalışıyor. en iyisi şekil oluşturup tıklayınca çalışsın diye düşünüyorum ne dersiniz ? veya aşağıdaki kodlarda bir değişiklikmi yapmak lazım hocam ?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bul As Range
If Not Intersect(Target, Range("I2:I" & Rows.Count)) Is Nothing Then
Set Bul = Worksheets("Renk Kodları").Range("A:A").Find(what:=Left(Target.Text, 1), lookat:=xlWhole)
Range("A" & Target.Row & ":BL" & Target.Row).Interior.Color = Bul.Offset(0, 1).Interior.Color
End If
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Veri As Range, Son As Long, Usd As Variant, Try As Variant, Satir As Long

Son = Cells(Rows.Count, "B").End(3).Row

If Intersect(Target, Range("A2:H" & Son)) Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next

For Each Veri In Intersect(Target, Range("A2:H" & Son)).Cells
If Satir <> Veri.Row Then
Try = Cells(Veri.Row, "E")
Usd = Cells(Veri.Row, "H")
If Veri.Column = 5 Then
If Try = Empty Then
Cells(Veri.Row, "F").ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
ElseIf IsNumeric(Try) Then
Cells(Veri.Row, "F") = Try / Cells(Veri.Row, "C")
Cells(Veri.Row, "G") = Cells(Veri.Row, "F") / Range("W2")
Cells(Veri.Row, "H") = Try / Range("W2")
End If
ElseIf Veri.Column = 8 Then
If Usd = Empty Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
ElseIf IsNumeric(Usd) Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
End If
Else
If Try <> "" Then
If IsNumeric(Try) Then
Cells(Veri.Row, "F") = Try / Cells(Veri.Row, "C")
Cells(Veri.Row, "G") = Cells(Veri.Row, "F") / Range("W2")
Cells(Veri.Row, "H") = Try / Range("W2")
End If
ElseIf Usd <> "" Then
If IsNumeric(Usd) Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
End If
End If
End If
End If
Satir = Veri.Row
Next

On Error GoTo 0

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
 
Option Explicit satırı her zaman Deklarasyon kısmında (kodların en üstünde) olmak zorunda.
Bir prosedür yada fonksiyon ismi bir kod sayfasında iki kere kullanılamaz.
Private Sub Worksheet_Change(ByVal Target As Range) İki kere kullanılmış.

Aşağıdaki kodu deneyin.
Eğer olmazsa dosyanızın son halini paylaşın kontrol edelim.
Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bul As Range
If Not Intersect(Target, Range("I2:I" & Rows.Count)) Is Nothing Then
Set Bul = Worksheets("Renk Kodları").Range("A:A").Find(what:=Left(Target.Text, 1), lookat:=xlWhole)
Range("A" & Target.Row & ":BL" & Target.Row).Interior.Color = Bul.Offset(0, 1).Interior.Color
End If

Dim Veri As Range, Son As Long, Usd As Variant, Try As Variant, Satir As Long

Son = Cells(Rows.Count, "B").End(3).Row

If Intersect(Target, Range("A2:H" & Son)) Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next

For Each Veri In Intersect(Target, Range("A2:H" & Son)).Cells
If Satir <> Veri.Row Then
Try = Cells(Veri.Row, "E")
Usd = Cells(Veri.Row, "H")
If Veri.Column = 5 Then
If Try = Empty Then
Cells(Veri.Row, "F").ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
ElseIf IsNumeric(Try) Then
Cells(Veri.Row, "F") = Try / Cells(Veri.Row, "C")
Cells(Veri.Row, "G") = Cells(Veri.Row, "F") / Range("W2")
Cells(Veri.Row, "H") = Try / Range("W2")
End If
ElseIf Veri.Column = 8 Then
If Usd = Empty Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
ElseIf IsNumeric(Usd) Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
End If
Else
If Try <> "" Then
If IsNumeric(Try) Then
Cells(Veri.Row, "F") = Try / Cells(Veri.Row, "C")
Cells(Veri.Row, "G") = Cells(Veri.Row, "F") / Range("W2")
Cells(Veri.Row, "H") = Try / Range("W2")
End If
ElseIf Usd <> "" Then
If IsNumeric(Usd) Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
End If
End If
End If
End If
Satir = Veri.Row
Next

On Error GoTo 0

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
 
Muzaffer Ali' Alıntı:
Option Explicit satırı her zaman Deklarasyon kısmında (kodların en üstünde) olmak zorunda.
Bir prosedür yada fonksiyon ismi bir kod sayfasında iki kere kullanılamaz.
Private Sub Worksheet_Change(ByVal Target As Range) İki kere kullanılmış.

Aşağıdaki kodu deneyin.
Eğer olmazsa dosyanızın son halini paylaşın kontrol edelim.
Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bul As Range
If Not Intersect(Target, Range("I2:I" & Rows.Count)) Is Nothing Then
Set Bul = Worksheets("Renk Kodları").Range("A:A").Find(what:=Left(Target.Text, 1), lookat:=xlWhole)
Range("A" & Target.Row & ":BL" & Target.Row).Interior.Color = Bul.Offset(0, 1).Interior.Color
End If

Dim Veri As Range, Son As Long, Usd As Variant, Try As Variant, Satir As Long

Son = Cells(Rows.Count, "B").End(3).Row

If Intersect(Target, Range("A2:H" & Son)) Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next

For Each Veri In Intersect(Target, Range("A2:H" & Son)).Cells
If Satir <> Veri.Row Then
Try = Cells(Veri.Row, "E")
Usd = Cells(Veri.Row, "H")
If Veri.Column = 5 Then
If Try = Empty Then
Cells(Veri.Row, "F").ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
ElseIf IsNumeric(Try) Then
Cells(Veri.Row, "F") = Try / Cells(Veri.Row, "C")
Cells(Veri.Row, "G") = Cells(Veri.Row, "F") / Range("W2")
Cells(Veri.Row, "H") = Try / Range("W2")
End If
ElseIf Veri.Column = 8 Then
If Usd = Empty Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
ElseIf IsNumeric(Usd) Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
End If
Else
If Try <> "" Then
If IsNumeric(Try) Then
Cells(Veri.Row, "F") = Try / Cells(Veri.Row, "C")
Cells(Veri.Row, "G") = Cells(Veri.Row, "F") / Range("W2")
Cells(Veri.Row, "H") = Try / Range("W2")
End If
ElseIf Usd <> "" Then
If IsNumeric(Usd) Then
Cells(Veri.Row, "E").Resize(1, 3).ClearContents
Cells(Veri.Row, "G") = Usd / Cells(Veri.Row, "C")
End If
End If
End If
End If
Satir = Veri.Row
Next

On Error GoTo 0

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Muzaffer hocam oldu sağolasınız çok teşekkürler...

sayenizde Bir prosedür yada fonksiyon ismi bir kod sayfasında iki kere kullanılamaz olduğunu öğrendim.
dolayısıyla çakışıyormuş.

sizde bertaraf etmek için Option Explicit ifadesini en üste almışınız.

modüle dönüştürmeyede gerek kalmadı.harikasınız.

size ve excel web ailesine kucak dolusu saygılar sevgiler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst