• DİKKAT

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

Koşullu formül ile yinelenleri bulunan dosyada, makrolu çözüm nasıl olur?

A

assenucler

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,588
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Pro x64 TR
Değerli Dostlar;


Laptopum da Office 365 TR 64x yüklü. "ARALIKBİRLEŞTİR" formülü ile Koşullu Biçimlendirme'de "yinelenen kayıtları" bulabiliyorum.
1 yıllık işlem sayısı 1800 - 2000 satır aralığında olup, 80 kayıt içeren dosyayı ekte yolluyorum.

Sizlerden makroyla çözüm konusunda değerli yardımlarınızı bekliyorum.
 

Ekli dosyalar

Son düzenleme:
Deneyiniz..

Kod: 
Sub Test()
    Dim Zmn, Rng, Renk, Dizi
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Zmn = Timer
    Set Rng = Range(Cells(2, 13), Cells(Cells(Rows.Count, 1).End(3).Row, 13))
    Rng.Interior.ColorIndex = xlNone
    Rng.FormulaR1C1 = "=CONCAT(RC[-12]:RC[-1])"
    Rng.Value = Rng.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    For Each Renk In Rng
        If Renk <> "" Then
            Dizi(Renk.Value) = Dizi(Renk.Value) + 1
        End If
    Next
    For Each Renk In Rng
        If Dizi(Renk.Value) > 1 Then
            Renk.Interior.ColorIndex = 6
        End If
    Next
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Isleminiz tamam suresi  " & Format(Timer - Zmn, "0.00") & " Saniye"
End Sub
 

Ekli dosyalar

Sayın @EmrExcel16,


Kısa süredeki yanıtınız için teşekkür ederim.

Acaba, renklendirme A:L sütun satırlarında; formüller ise M sütunu yerine Z sütununda olabilir mi?
Her şey gönlünüzce ve kazancınız bol olsun.

En içten sevgi ve saygılarımla,
 
Bu şekilde dener misiniz sayın @assenucler , doğru anlamış mıyım bakalım.

Kod: 
Sub Test()
    Dim Zmn, Rng, Renk, Dizi
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Zmn = Timer
    Set Rng = Range(Cells(2, 26), Cells(Cells(Rows.Count, 1).End(3).Row, 26))
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(3).Row, 12)).Interior.Color = xlNone
    Rng.FormulaR1C1 = "=CONCAT(RC[-25]:RC[-14])"
    Rng.Value = Rng.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    For Each Renk In Rng
        If Renk <> "" Then
            Dizi(Renk.Value) = Dizi(Renk.Value) + 1
        End If
    Next
    For Each Renk In Rng
        If Dizi(Renk.Value) > 1 Then
            Range(Cells(Renk.Row, 1), Cells(Renk.Row, 12)).Interior.Color = vbYellow
        End If
    Next
    Rng.ClearContents
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Isleminiz tamam suresi  " & Format(Timer - Zmn, "0.00") & " Saniye"
End Sub
 
Son düzenleme:
Sayın @EmrExcel16,

Kod çalışıyor.

M sütun satırlarında formül metinleri olmamalıdır. Makro kodunda çok büyük bir değişiklik olmayacaksa; Z sütununda da formül gözükmesinin bir gereği yoktur.

Yakın ilginiz için tekrar teşekkürler.
 
#4 numaralı mesajımda ki kodu revize ettim dener misiniz. Son verdiğim kodlar ile M sütununda işlemimiz yok bir kere manual silin bir daha eklemeyecektir.
 
Z sütunundaki kodları sildi. M sütununda kodlar gözüküyor.

Formüller M sütununda da gözükmesin.
 
Hüseyin Bey,

Yolladığım her bir mesaj, sitede 2 kez çıkıyor.

Nedeni ne olabilir?
 
Sayın @EmrExcel16,


Yukarıda 8. iletideki dosyanızı halen kullanmaktayım. Ancak, birden fazla aynı kayıt girişi yaptığım olabiliyor.

İsteğim; İkinci bir kayıt girişi olduğunda "P" sütunundaki hücreye "ÇİFT KAYIT" sözcüğü eklenmesi için, kodunuza nasıl bir ekleme gerekiyor?

Yardımınızı rica edebilir miyim?
 
Kod aynı olan satırları sarı ile renklendiriyor, aynı zamanda "P" sütununa "ÇİFT KAYIT" mı yazsın istiyorsursunuz ?
 
Üstadım,

Dosyanın son halinde 5-6 makro kodu var. Durumu "Ödendi" olanlar, bir başka koşullu biçimlendirme formülle "Yeşil" renk alıyor.
Evet, sizden ricam "P" sütununda "ÇİFT KAYIT" yazsın; sarı renk kodu, yeşil olsun.

İlginiz için teşekkür ederim.
 
Son düzenleme:
Deneyiniz..
Kod: 
Option Explicit
Sub Test()
    Dim Zmn, Rng, Renk, Dizi
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Zmn = Timer
    Set Rng = Range(Cells(2, 26), Cells(Cells(Rows.Count, 1).End(3).Row, 26))
    Range("P2:P10000").ClearContents
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(3).Row, 12)).Interior.Color = xlNone
    Rng.FormulaR1C1 = "=CONCAT(RC[-25]:RC[-14])"
    Rng.Value = Rng.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    For Each Renk In Rng
        If Renk <> "" Then
            Dizi(Renk.Value) = Dizi(Renk.Value) + 1
        End If
    Next
    For Each Renk In Rng
        If Dizi(Renk.Value) > 1 Then
            Range(Cells(Renk.Row, 1), Cells(Renk.Row, 12)).Interior.Color = vbGreen
            Cells(Renk.Row, 16) = "ÇİFT KAYIT"
        End If
    Next
    Rng.ClearContents
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Isleminiz tamam suresi  " & Format(Timer - Zmn, "0.00") & " Saniye"
End Sub
 
Sayın @EmrExcel16,


Üstadım öncelikle kısa süredeki yanıtınız için teşekkür ederim. Allah sizden razı ve kazancınız bol olsun.
Kodlar çok güzel çalışıyor.

Sizden bir uygun bir zamanınızda bir ricam daha olacaktır. Şöyle ki:

Koda filtreleme koyarak, tüm çift kayıtları alt alta getirmeniz mümkün mü?
 
İyi dilekleriniz için teşekkür ederim,Allah hepimizden razı olsun.

İsteğiniz , filtre uygulayıp ve filtreden çift kayıt yazanları süzmek mi ?
 
Deneyiniz..
Kod: 
Option Explicit
Sub Test()
    Dim Zmn, Rng, Renk, Dizi
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    ActiveSheet.AutoFilterMode = False
    Zmn = Timer
    Set Rng = Range(Cells(2, 26), Cells(Cells(Rows.Count, 1).End(3).Row, 26))
    Range("P2:P10000").ClearContents
    Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(3).Row, 12)).Interior.Color = xlNone
    Rng.FormulaR1C1 = "=CONCAT(RC[-25]:RC[-14])"
    Rng.Value = Rng.Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    For Each Renk In Rng
        If Renk <> "" Then
            Dizi(Renk.Value) = Dizi(Renk.Value) + 1
        End If
    Next
    For Each Renk In Rng
        If Dizi(Renk.Value) > 1 Then
            Range(Cells(Renk.Row, 1), Cells(Renk.Row, 12)).Interior.Color = vbGreen
            Cells(Renk.Row, 16) = "ÇİFT KAYIT"
        End If
    Next
    Rng.ClearContents
    Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(3).Row, 16)).AutoFilter Field:=16, Criteria1:="ÇİFT KAYIT"
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Isleminiz tamam suresi  " & Format(Timer - Zmn, "0.00") & " Saniye"
End Sub
 

Ekli dosyalar

Sayın @EmrExcel16,

Siz ve tüm üstatlarımız; bıkmadan, usanmadan, bir menfaat beklentisi olmaksızın, bizlere yol gösteriyor, ışığımız oluyor ve eğitiyorsunuz. Allah'ım sizler gibi gönül dostlarımızı başımızdan eksik etmesin. Her şey gönlünüzün güzelliğince olsun.

En içten sevgi ve saygılarımı sunarım.

Selim Şenüçler
 
Selim Bey , bu güzel sözler ve iyi dilekleriniz için bende tüm üstatlarımız adına teşekkür ederim saygı bizden , esen kalın...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst