Bir sütunda hücrenin rengi ne ise ona göre bir veri yazmak

[u.L.a.s]

Merhabalar

Örneğin O sütununda her hücrede belirlenmiş veriler olacak. aşağıdaki örnekte gibi basit bir makro koduna ihtiyacım var. bu sütunda hücre rengine göre sabit bir veriyi yazsın istiyorum. bilgi ve yardımlarınızı rica ederim

Hücre rengi yok ise hücre içeriğinde "aaa" yazsın
hücre rengini ben sarı yaparsam aaa verisi değişip yerine "bbb" yazsın
hücre rengini mavi yaparsam "ccc" yazsın

 

[YUSUF44]

Tam tersini yapmak daha pratik olmaz mı? aaa yazdığınızda dolgu olmasa, bbb yazdığınızda sarı olsa, ccc yazdığınızda mavi olması daha pratik olur bence.

 

[u.L.a.s]

yok aslında yazılacak veri uzun olacağı için ben o hücreye o rengi verince istediğim veriyi yazsın istiyorum.

maksat zaten burada uzun veriyi en kısa yoldan hücreye yazdırmak

 

[YUSUF44]

Daha pratik bir yöntem de var: bir sayfada hangi kısaltma yazıldığında hangi metne dönüşeceğini listelersiniz, daha sonra o hücrelere istediğiniz kısaltmayı girdiğinizde metni değişir. Örneğin 1 ise şuna dönüştür, 2 ise buna dönüştür gibi. Fareyle renk değiştirmekten daha pratik olur bence.

 

[u.L.a.s]

evet oda olabilir öyle hazır makro bir kod var mı elinde hazırda

 

[u.L.a.s]

Bu kod düzeneği ile dediğin şekilde bir harf yazarak diğer yazılacak veriyi yazdırdım. Teşekkürler
.
ama yinede bilgi olsun diye renk vererek bilgi yazdıran bir makro kodu bilgisi olan varsa bu konu altına yazarsada sevinirim.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [O2:O65536]) Is Nothing Then
On Error Resume Next
If Not Target.Value = "" Then

Application.EnableEvents = False
Target.Value = Application.WorksheetFunction.Proper(Target.Value)
Application.EnableEvents = True
End If
End If
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("O:O")) Is Nothing Then
Application.EnableEvents = False
bul = Array("t", "k", "m", "x")
deg = Array("Tesis Tamam", "Tesis Tamam-Kablo Çekildi", "Tesis Tamam-Mimari İşlerde", "Tesis Tamamlanmadı-Kablo Çekildi")
metin = Split(Target.Value, " ")
For b = LBound(metin) To UBound(metin)
    For C = LBound(bul) To UBound(bul)
        If InStr(1, metin(b), bul(C), vbTextCompare) = 1 Then
            metin(b) = deg(C)
            Exit For
        End If
    Next
Next
Target.Value = Join(metin, " ")
Application.EnableEvents = True
End If
End sub

 

[YUSUF44]

Sayfa2'nin A sütununda kodlar/kısaltmalar, B sütununda uzun metinler olduğunu varsayarsak, aşağıdaki kodları sayfa1'in kod bölümüne yapıştırırsanız, A5:A100 aralığında girdiğiniz kodları istediğiniz metne dönüştürür. Yazdığınız kod sayfa2'de yoksa hücreyi kırmızı yapar:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A5:A100]) Is Nothing Then Exit Sub
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
Set s2 = Sheets("Sayfa2")
son = s2.Cells(Rows.Count, "A").End(3).Row
If WorksheetFunction.CountIf(s2.Range("A1:A" & son), Target) > 0 Then
    Target = WorksheetFunction.VLookup(Target, s2.Range("A1:B" & son), 2, 0)
    Target.Interior.Color = xlNone
Else
    Target.Interior.Color = vbRed
End If
End Sub

 

[u.L.a.s]

Selamlar

Private Sub Worksheet_Change(ByVal Target As Range) sub'ı altında bir kaç tane ayrı ayrı makro kod var. aşağıdaki gibi.

en son cevaptaki kodu ben bu kod düzeneğinde en sona koyarsam önceki kodlardan ötürü sanırım çalışmıyor.

bu sefer başa alıyorum. kendisi çalışıyor ama sonrasındaki kodlar çalışmıyor. bütün kodların bu sub altında çalışabilmesi için ne yapmak gerekir bilgilerinizi rica ederim

Private Sub Worksheet_Change(ByVal Target As Range)

    
'*********************************************************************************************************************
'*********************************************************************************************************************
'C sütununda bulunan adres bilgisinde mahalle cadde sokak bulvar kelimelerini kısaltır mah. sok. cad. blv. yapar
'*********************************************************************************************************************
'*********************************************************************************************************************
If Not Intersect(Target, [B2:C65536]) Is Nothing Then
On Error Resume Next
If Not Target.Value = "" Then

Application.EnableEvents = False
Target.Value = Application.WorksheetFunction.Proper(Target.Value)
Application.EnableEvents = True
End If
End If
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C:C")) Is Nothing Then
Application.EnableEvents = False
bul = Array("mahalle", "cadde", "sokak", "bulvar")
deg = Array("mah.", "cad.", "sok.", "blv.")
metin = Split(Target.Value, " ")
For b = LBound(metin) To UBound(metin)
    For C = LBound(bul) To UBound(bul)
        If InStr(1, metin(b), bul(C), vbTextCompare) = 1 Then
            metin(b) = deg(C)
            Exit For
        End If
    Next
Next
Target.Value = Join(metin, " ")
Application.EnableEvents = True
End If


'+++++++++++++++++++++++++++++++++++++Bu Sub Devam Ediyor+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'*********************************************************************************************************************
'*********************************************************************************************************************
'F sütununda bulunan yeniMe veya eskiME şeklinde başlayan port bilgisi ibarelerinin G sütununa veri girince yeni ve eski ibaresinin kalkması
'*********************************************************************************************************************
'*********************************************************************************************************************
If Not Intersect(Target, Range("G:G")) Is Nothing Then
    If Not Target.Value = "" Then
        Target.Offset(0, -1) = Replace(Target.Offset(0, -1), "yeni", "")
        Target.Offset(0, -1) = Replace(Target.Offset(0, -1), "eski", "")
        Cells(Target.Row, "O") = "Tesis Tamam"
        'Cells(Target.Row, "P") = Date
    Else
        Cells(Target.Row, "O") = "Tesis Tamamlanmadı"
        'Cells(Target.Row, "P") = ""
    End If
End If

'+++++++++++++++++++++++++++++++++++++Bu Sub Devam Ediyor+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'*********************************************************************************************************************
'*********************************************************************************************************************
'O sütununda bulunan hücrelere yazılan kısa değer ne ise uzun değeri karşısına getirir
'*********************************************************************************************************************
'*********************************************************************************************************************

If Intersect(Target, [O2:O65100]) Is Nothing Then Exit Sub
On Error Resume Next
If Selection.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
Set S2 = Sheets("Kısaltma")
Son = S2.Cells(Rows.Count, "A").End(3).Row
If WorksheetFunction.CountIf(S2.Range("A1:A" & Son), Target) > 0 Then
    Target = WorksheetFunction.VLookup(Target, S2.Range("A1:B" & Son), 2, 0)
    Target.Interior.Color = xlNone
Else
    Target.Interior.Color = vbRed
End If

'+++++++++++++++++++++++++++++++++++++Bu Sub Devam Ediyor+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'*********************************************************************************************************************
'*********************************************************************************************************************
'F sütununda girilen telefon numaraları aradaki harf veya özel karakterleri kaldırıp sadece rakamları yazar
'*********************************************************************************************************************
'*********************************************************************************************************************

If Intersect(Target, [J:J]) Is Nothing Then Exit Sub
If Target = "" Or IsNumeric(Target) = True Then Exit Sub
rakam = Target
For K = 1 To Len(Target.Value)
If IsNumeric(Mid(rakam, K, 1)) = False Then rakam = Replace(rakam, Mid(rakam, K, 1), "")
Next: Target = rakam & ""



End Sub

 

[YUSUF44]

Bunun için dosya paylaşırsanız iyi olur çünkü verdiğimiz kodu denememiz gerekir. Hangi durumda ne olması gerektiğini de belirtin lütfen.

 

[u.L.a.s]

üstadım merhaba

örnek dosya aşağıdaki linkte olup dosyada gerekli yerlere gerekli açıklamaları yazdım. teşekkür ederim

https://dosya.co/9u6b5xyaot7q/ornek.rar.html

 

[YUSUF44]

Aşağıdaki gibi dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Selection.Count > 1 Then Exit Sub

'C sütununda bulunan adres bilgisinde mahalle cadde sokak bulvar kelimelerini kısaltır mah. sok. cad. blv. yapar
    
    If Intersect(Target, [B2:C65536]) Is Nothing Then GoTo 10
        If Target = "" Then Exit Sub
        Application.EnableEvents = False
            Target = WorksheetFunction.Proper(Target.Value) 'B sütununa girilen verilerde baş harfleri büyük yapıyor
            If Target.Column = 3 Then
                bul = Array("mahalle", "cadde", "sokak", "bulvar")
                deg = Array("mah.", "cad.", "sok.", "blv.")
                metin = Split(Target.Value, " ")
                For b = LBound(metin) To UBound(metin)
                    For C = LBound(bul) To UBound(bul)
                        If InStr(1, metin(b), bul(C), vbTextCompare) = 1 Then
                            metin(b) = deg(C)
                            Exit For
                        End If
                    Next
                Next
                Target.Value = Join(metin, " ")
            End If
        Application.EnableEvents = True

'F sütununda bulunan yeniMe veya eskiME şeklinde başlayan port bilgisi ibarelerinin G sütununa veri girince yeni ve eski ibaresinin kalkması
10:
    If Intersect(Target, Range("G:G")) Is Nothing Then GoTo 20
        If Target <> "" Then
            Target.Offset(0, -1) = Replace(Target.Offset(0, -1), "yeni", "")
            Target.Offset(0, -1) = Replace(Target.Offset(0, -1), "eski", "")
            Cells(Target.Row, "O") = "Tesis Tamam"
            'Cells(Target.Row, "P") = Date
        Else
            Cells(Target.Row, "O") = "Tesis Tamamlanmadı"
            'Cells(Target.Row, "P") = ""
        End If

'O sütununda bulunan hücrelere yazılan kısa değer ne ise uzun değeri karşısına getirir
20:
    If Intersect(Target, [O2:O65100]) Is Nothing Then GoTo 30
        If Target = "" Then Exit Sub
        Set S2 = Sheets("Sayfa2")
        Son = S2.Cells(Rows.Count, "A").End(3).Row
        If WorksheetFunction.CountIf(S2.Range("A1:A" & Son), Target) > 0 Then
            Target = WorksheetFunction.VLookup(Target, S2.Range("A1:B" & Son), 2, 0)
            Target.Interior.Color = xlNone
        Else
            Target.Interior.Color = vbRed
        End If

'J sütununda girilen telefon numaraları aradaki harf veya özel karakterleri kaldırıp sadece rakamları yazar
30:
    If Intersect(Target, [J:J]) Is Nothing Then Exit Sub
        If Target = "" Or IsNumeric(Target) = True Then Exit Sub
        rakam = Target
        'yukarıda j sütunu kodu ok de aşağıdaki kodda k sütunu neden kullanılmış hiç anlamadım
        For K = 1 To Len(Target.Value)
            If IsNumeric(Mid(rakam, K, 1)) = False Then rakam = Replace(rakam, Mid(rakam, K, 1), "")
        Next: Target = rakam & ""

End Sub

 

[u.L.a.s]

üstadım emeğine bilgine sağlık gayet başarılı ve güzel oldu.

 

[Cerenk]

Merhaba;
Hücre rengi yeşil ise belirli bir sütuna "İADE"yazmasını istiyorum.Bunun için yardımcı olur musunuz?

 

[YUSUF44]

Merhaba;
Hücre rengi yeşil ise belirli bir sütuna "İADE"yazmasını istiyorum.Bunun için yardımcı olur musunuz?

Bunun için örnek dosya olması iyi olur. Çünkü bahsettiğiniz yeşil rengin nasıl olduğu ve hücreye nasıl eklendiği önemlidir. Ayrıca hangi hücreye bakılıp hangi hücrede değişiklik yapılacağı da önemlidir.

Örnek olarak aşağıdaki gibi bir makro F1:F50 arasını kontrol eder ve yeşilse G sütununa İADE yazar:

Sub renkiade()
For i = 1 to 50
    If Cells(i,"F").Interior.Color =vbGreen Then
        Cells(i,"G") = "İADE"
    End If
Next
End Sub

 

[Cerenk]

Google Sheets: Sign-in

Access Google Sheets with a personal Google account or Google Workspace account (for business use).

docs.google.com

 

[YUSUF44]

Erişim izni vermemişsiniz.