• DİKKAT

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

Renklendirme kodunu satır aralığında yaptırmak

E

EKREM1661

Katılım
10 Kasım 2006
Mesajlar
1,288
Excel Vers. ve Dili
Excel-2016
Arkadaşlar..! Aşağıdaki makro kodu; 1.Sayfa "M" sütununda olan verilerle, 2.Sayfa "B" sütununda olan verileri karşılaştırarak, aynı bulduğu verileri 2.Sayfa "B" sütununda renklendiriyor.

Bu renklendirmeyi hücre bazında yapıyor, Bunu tek hücrede değil de "A:L" satır aralığında nasıl yaptırırız..

Sub MukayeseKontrolü()

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

s1.Select
son = s1.Cells(Rows.Count, "M").End(3).Row
For Each i In Range("M2:M" & son)
adet = WorksheetFunction.CountIf(s2.Range("B:B"), i.Value)
If adet > 0 Then
i.Interior.ColorIndex = 36
End If
Next i

s2.Select
son = s2.Cells(Rows.Count, "B").End(3).Row
For Each i In Range("B2:B" & son)
adet = WorksheetFunction.CountIf(s1.Range("M:M"), i.Value)
If adet > 0 Then
i.Interior.ColorIndex = 36
End If
Next i
Genişletmek için tıkla ...
 
Merhaba
Bir öneri, ben bunu denemedim ama sonuç alabileceğini umuyorum.
Kod: 
For Each i In Range("M2:M" & son)
olan satırı
Kod: 
For Each i In Range("A2:L" & son)
olarak yada buradaki değerleri değiştirerek deneyebilirsin.
 
Merhaba,

Dosya ekleyerek açıklarsanız sorunuz netlik kazanacaktır.
 
İsmail bey..! Olmadı, uzun müddet donuyor ve yine aynı sonuç çıkıyor..
 
Kod yapısını da değiştirdim, bu şekilde daha hızlı çalışacaktır.

Kod: 
Sub MukayeseKontrolü()
 
    Dim i As Long, c As Range, Adr As String, S2 As Worksheet
 
    Set S2 = Sheets("Sayfa2")
 
    Application.ScreenUpdating = False
 
    Sheets("Sayfa1").Select
    Range("M2:M" & Rows.Count).Interior.ColorIndex = 0
    S2.Range("A2:L" & Rows.Count).Interior.ColorIndex = 0
 
    For i = 2 To Cells(Rows.Count, "M").End(xlUp).Row
        With S2.Range("B:B")
            Set c = .Find(Cells(i, "M"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Cells(i, "M").Interior.ColorIndex = 36
                Adr = c.Address
                Do
                    c.Offset(0, -1).Resize(, 12).Interior.ColorIndex = 36
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
     Next i
 
    Application.ScreenUpdating = True
 
End Sub

.
 
Saygıdeğer hocam, ne kadar teşekkür etsem yeridir.. Dediğiniz gibi oldu, çok hızlandı ve hocam elini bulaştırmışken ve de sizi yormayacaksa, bu konuya bağlı olarak şöyle bir şey olursa da çok makbule geçecek.

Sayfa2 de renklenen isimleri bir üçüncü sayfaya aktarmak istiyorum.
Fakat aktarırken de, 1.Sayfadaki M sütunu karşılığında bulunan "D" sütunu verisini de, 3.Sayfa "E" sütununa aldırmam lazım.. Bir başka butonla..(Ek)
 

Ekli dosyalar

Son düzenleme:
Neden bir başka buton istiyorsunuz, aynı anda yaparsanız işlemleriniz hızlaşır.
 
Dediğiniz daha isabetlidir hocam, elbetki daha iyi olur.. Hocam butonu ayrı olsun dediğimdeki maksat, 3.sayfaya yapılacak mükerreri ayrıca kontrol içindi; yoksa eğer mükerrer olabilecek veriyi de kontrol ederek (mükerreri aktarmadan) olmuş olsa elbet çok daha harikulade olacak..
 
Tam anlayamadım. Sonuc itibariyle aynı kodun içine mi ekliyeyim yoksa ayrı bir kod bloğu mu olsun.
 
Hocam.. Her ikisi de olur, gerçi; Fakat siz, her iki işi bir anda yapsın dedikten sonra, bende sizin görüşünüz doğrultusunda fikir değiştirdim.. Tabii ki aynı kodun içerisinde olsun ve iki işi bir anda yapsın.. Ve de 3.Sayfaya mükerrer kayıt yapmayacak.. Bu işte olursa artık söyleyecek başka bir şey kalmayacak.. Tüm yardımlarınıza minnettarım..
 
Ömer hocam..! Bu biraz karışık konu oldu ve anlattığım konuyu ben bile anlamadım.. Bu nedenle bu şekil çözümden vaz geçtim.. Bunu, elimde var olan ve benzersizleri veren KTF formülünün işlevini tersine çevirip, benzer/çift olanı veren şekle dönüştürürsek bu iş daha kısa yoldan halledilecek gibi geldi bana.. Konu da farklı olduğu için (Eşleşeni veren KTF) başlığı altında yeni bir konu açmış oldum. Bununla birlikte ve sizi de yormamak adına bu bilgi notunu düştüm..
 
Son düzenleme:
İş yoğunluğundan geri dönüşlerim bazen geç olabiliyor.

Yapıyı değiştirmeden küçük ilavelerle istediğiniz yapılabilir. Aşağıdaki kodlar istediğinizi yapar. Ktf yada bu şekilde kullanıp kullanmayacağınız sizin tercihinizdir.

Kod: 
Sub MukayeseKontrolü()
 
    Dim i As Long, c As Range, Adr As String, sat As Long
    Dim S2 As Worksheet, S3 As Worksheet
 
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
 
    Application.ScreenUpdating = False
 
    Sheets("Sayfa1").Select
    Range("M2:M" & Rows.Count).Interior.ColorIndex = 0
    S2.Range("A2:L" & Rows.Count).Interior.ColorIndex = 0
    S3.Range("B2:E" & Rows.Count).Clear
 
    sat = 2
    For i = 2 To Cells(Rows.Count, "M").End(xlUp).Row
        With S2.Range("B:B")
            Set c = .Find(Cells(i, "M"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Cells(i, "M").Interior.ColorIndex = 36
                c.Resize(, 3).Copy S3.Cells(sat, "B")
                S3.Cells(sat, "E") = Cells(i, "D")
                sat = sat + 1
                Adr = c.Address
                Do
                    c.Offset(0, -1).Resize(, 12).Interior.ColorIndex = 36
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
     Next i
 
    Application.ScreenUpdating = True
 
End Sub
.
 
Hocam.. Kusura kalmayın, uyarlayamadım.. Elinize sağlık herşey tamam, renklendirmelerinde sorun yok sadece Sayfa1 "D" sütununu da SONUÇ (Sayfa3) "c" sütununa aktarılması lazım.. örnek ekte..
 

Ekli dosyalar

Verilerin yeri tamamen değişmiş, buna göre renklendirme de sorun olacaktır. Örneğin Sayfa1 M sütununa göre arama yapıyordu, şuan M sütununda veri yok.

Açıklamaların tümünü yeniden yapınız.
 
Hocam haklısınız.. M sütununda veri var da, daha kolay anlaşılsın diye sildim.. Örnek dosya ekliyorum...
 

Ekli dosyalar

Son düzenleme:
Sayın Ekrem,

Renklendirme kodu kaldırılacak sanırım, doğru mu? Sadece aktarma mı olacak.
 
Hocam..! Renklendirme kodu, beraberinde olsa da olur, olmasa da.. Renklendirme kodunu 2.sayfada atama yapılan personeli görmek içindi..
Daha sonra renkli olanları, yani atanan yer değişenleri bir 3.sayfaya aktarıp görmek ve çıktısını almak için bir düşünce doğdu..
Ki, atanan personel (1 ve 2.sayfada eşleşen olmuş oluyor) 3.sayfaya süzüldükten sonra, renklendirmenin çok da fazla bir gereği kalmadı diyebiliriz.. Fakat gerekirse, yine sizin ilk yaptığınız kodu (2.sayfa için) bir buton altında kullanabiliriz..Onun için renklendirme artık o kadar önemli değil.. Sizin dilediğiniz gibi olursa daha sağlıklı olur..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst