• DİKKAT

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

Birebir Aynı İçeriğe Sahip Sütunları Bulmak

R

rafetgulmez

Katılım
21 Mart 2009
Mesajlar
60
Excel Vers. ve Dili
2007 türkçe
Aynı içeriğe sahip sütunları "bulmak" ve aynı olanları "işaretlemek" istiyoruz... Yardımlarınız için tşk. ederim....:roll::roll:


Örnek dosya ektedir...
 

Ekli dosyalar

Rakamlar değişik yerlerde olsa fark eder mi ?
 
Selamlar,

Aşağıdaki linki incelermisiniz.

Sütunları blok halinde eşleştirmek


Ayrıca tüm sütunları kontrol etmek için aşağıdaki koduda kullanabilirsiniz.

Kod: 
Option Explicit
 
Sub MÜKERRER_SÜTUN_KONTROLÜ()
    Dim İLK As Date, SON As Date, SÜRE As Date
    Dim RENK As Byte, X As Byte, Y As Byte, SAY1 As Long, SAY2 As Long
    Dim SON_SATIR As Long, ADRES1 As String, ADRES2 As String
 
    İLK = Time
    
    Range("C4:IV4").Interior.ColorIndex = xlNone
    SON_SATIR = Range("C65536").End(3).Row
    RENK = 3
    
    For X = 3 To Range("IV4").End(1).Column
        ADRES1 = Range(Cells(5, X), Cells(SON_SATIR, X)).Address
        SAY1 = WorksheetFunction.CountA(Range(ADRES1))
        For Y = 3 To Range("IV4").End(1).Column
            If X <> Y Then
                ADRES2 = Range(Cells(5, Y), Cells(SON_SATIR, Y)).Address
                SAY2 = Evaluate("=SUMPRODUCT(--(" & ADRES1 & "=" & ADRES2 & "))")
                If SAY1 = SAY2 Then
                    If Cells(4, X).Interior.ColorIndex = xlNone Then Cells(4, X).Interior.ColorIndex = RENK
                    If Cells(4, Y).Interior.ColorIndex = xlNone Then Cells(4, Y).Interior.ColorIndex = RENK
                    RENK = RENK + 1
                End If
            End If
        Next
    Next
    
    SON = Time
    
    SÜRE = Format((SON - İLK), "hh:mm:ss")
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
End Sub
 
Olmadı....

Korhan Ayhan' Alıntı:
Selamlar,

Aşağıdaki linki incelermisiniz.

Sütunları blok halinde eşleştirmek


Ayrıca tüm sütunları kontrol etmek için aşağıdaki koduda kullanabilirsiniz.

Kod: 
Option Explicit
 
Sub MÜKERRER_SÜTUN_KONTROLÜ()
    Dim İLK As Date, SON As Date, SÜRE As Date
    Dim RENK As Byte, X As Byte, Y As Byte, SAY1 As Long, SAY2 As Long
    Dim SON_SATIR As Long, ADRES1 As String, ADRES2 As String
 
    İLK = Time
    
    Range("C4:IV4").Interior.ColorIndex = xlNone
    SON_SATIR = Range("C65536").End(3).Row
    RENK = 3
    
    For X = 3 To Range("IV4").End(1).Column
        ADRES1 = Range(Cells(5, X), Cells(SON_SATIR, X)).Address
        SAY1 = WorksheetFunction.CountA(Range(ADRES1))
        For Y = 3 To Range("IV4").End(1).Column
            If X <> Y Then
                ADRES2 = Range(Cells(5, Y), Cells(SON_SATIR, Y)).Address
                SAY2 = Evaluate("=SUMPRODUCT(--(" & ADRES1 & "=" & ADRES2 & "))")
                If SAY1 = SAY2 Then
                    If Cells(4, X).Interior.ColorIndex = xlNone Then Cells(4, X).Interior.ColorIndex = RENK
                    If Cells(4, Y).Interior.ColorIndex = xlNone Then Cells(4, Y).Interior.ColorIndex = RENK
                    RENK = RENK + 1
                End If
            End If
        Next
    Next
    
    SON = Time
    
    SÜRE = Format((SON - İLK), "hh:mm:ss")
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
End Sub
Genişletmek için tıkla ...

Hocam verdiğiniz kodda satır ve sütun numaralarını filan çıkaramadım.. + Kod bilmediğimide düşünürseniz mantık yürüterek bile en ufak bi düzenleme yapamadım :yardim: + Verdiğiniz linkteki kodlar da aynı şekilde :???:
 
Selamlar,

Olmadı derken örnek dosyanıza göre önerdiğim kod çalışıyor. Kodları deneyerek göndermiştim. Sanıyorum siz kendi dosyanıza uyarlayamadınız.

Kendi dosyanızdaki verilerin başlangıç ve bitiş adreslerini açıklarsanız kodlarda gerekli düzenlemeyi yapabilirim.
 
Korhan Ayhan' Alıntı:
Selamlar,

Olmadı derken örnek dosyanıza göre önerdiğim kod çalışıyor. Kodları deneyerek göndermiştim. Sanıyorum siz kendi dosyanıza uyarlayamadınız.

Kendi dosyanızdaki verilerin başlangıç ve bitiş adreslerini açıklarsanız kodlarda gerekli düzenlemeyi yapabilirim.
Genişletmek için tıkla ...

Hocam C5:L17 ARASI... EK Lİ DOSYADA "SARI DOLGU" İLE İŞARETLEDİM....
 

Ekli dosyalar

Selamlar,

Dosyanızdaki en alt satırda yazan açıklamayı silin.

Ayrıca kod içindeki aşağıdaki satırı bir sonraki şekilde değiştirip deneyin.

Eski hali;
Kod: 
For X = 3 To Range("[COLOR=red]L[/COLOR]4").End(1).Column

Yeni hali;
Kod: 
For X = 3 To Range("[COLOR=red]IV[/COLOR]4").End(1).Column
 
Değişen bişey yok ....

Korhan Ayhan' Alıntı:
Selamlar,

Dosyanızdaki en alt satırda yazan açıklamayı silin.

Ayrıca kod içindeki aşağıdaki satırı bir sonraki şekilde değiştirip deneyin.

Eski hali;
Kod: 
For X = 3 To Range("[COLOR=red]L[/COLOR]4").End(1).Column

Yeni hali;
Kod: 
For X = 3 To Range("[COLOR=red]IV[/COLOR]4").End(1).Column
Genişletmek için tıkla ...

Dosyanızdaki en alt satırda yazan açıklamayı silin. (HOCAM AÇIKLAMADA YAZANI YAPMAYA ÇALIŞIYORUM..

DEDİĞİNİZ DEĞİŞİKLİKLERİ YAPTIM DEĞİŞEN BİŞEY OLMADI.... :frown: Bi gariplik var yanlış mı anlatıyorum acaba.... :???: Verdiğiniz kodalrı benim dosya üzerinde uygulayıp gönderebilirmisiniz....
 
Son düzenleme:
Selamlar,

Ekteki örnek dosyayı incelermisiniz.
 

Ekli dosyalar

Selamlar,

Dün örnek dosyayı ekledikten sonra daha fazla sütunlu tabloda önerdiğim kodu denediğimde renklerin karıştığını gözlemledim. Hatayı gidererek dosyayı revize ettim.

Ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;
Kod: 
Option Explicit
 
Sub MÜKERRER_SÜTUN_KONTROLÜ()
    Dim İLK As Date, SON As Date, SÜRE As Date
    Dim RENK As Byte, X As Byte, Y As Byte, SAY1 As Long, SAY2 As Long
    Dim SON_SATIR As Long, ADRES1 As String, ADRES2 As String
 
    İLK = Time
    
    Range("C4:IV4").Interior.ColorIndex = xlNone
    SON_SATIR = Range("C65536").End(3).Row
    RENK = 3
    
    For X = 3 To Range("IV4").End(1).Column
        ADRES1 = Range(Cells(5, X), Cells(SON_SATIR, X)).Address
        SAY1 = WorksheetFunction.CountA(Range(ADRES1))
        For Y = 3 To Range("IV4").End(1).Column
            If X <> Y And Cells(4, Y).Interior.ColorIndex = xlNone Then
                ADRES2 = Range(Cells(5, Y), Cells(SON_SATIR, Y)).Address
                SAY2 = Evaluate("=SUMPRODUCT(--(" & ADRES1 & "=" & ADRES2 & "))")
                If SAY1 = SAY2 Then
                    If Cells(4, X).Interior.ColorIndex = xlNone Then Cells(4, X).Interior.ColorIndex = RENK
                    If Cells(4, Y).Interior.ColorIndex = xlNone Then Cells(4, Y).Interior.ColorIndex = RENK
                End If
            End If
        Next
        RENK = RENK + 1
    Next
    
    SON = Time
    
    SÜRE = Format((SON - İLK), "hh:mm:ss")
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
End Sub
 

Ekli dosyalar

Korhan hocam merhaba, aynı şekilde benim de yardıma ihtiyacım A ve B sütunlarında ki veri birebi aynı iste en üste taşınıp arka planın kırmızı olması farklı olanların ise beyaz olması gerekiyor bu konuda yardımcı olur musunuz?

MyWork.xlsx - 1.2 MB
 
İşlem biraz uzun sürebilir.


Kod: 
Option Explicit

Sub AYNILARI_BUL_RENKLENDİR()
    Dim Say As Long, X As Long, Y As Long, Son As Long, Satir As Long, Zaman As Double
    
    Zaman = Timer
    
    Range("A:B").Interior.ColorIndex = xlNone
    Range("C:D").ClearContents
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Range("C1") = 1
    Range("C1").AutoFill Destination:=Range("C1:C" & Son), Type:=xlFillSeries

    For X = 1 To Son
        Cells(1, 5) = X
        Say = Evaluate("=SUMPRODUCT(--(B1:B" & Son & "=" & Cells(X, 1).Address & "))")
        For Y = 1 To Say
            Satir = 0
            On Error Resume Next
            Satir = Evaluate("=SMALL(IF(B1:B" & Son & "=" & Cells(X, 1).Address & ",IF(D1:D" & Son & "="""",ROW(B1:B" & Son & "))),1)")
            On Error GoTo 0
            If Satir = 0 Or Satir > X Then Exit For
            Cells(Satir, 4) = Cells(X, 3)
            Cells(X, 1).Interior.ColorIndex = 3
            Cells(Satir, 2).Interior.ColorIndex = 3
        Next
    Next

    Range("A1:D" & Son).Sort Range("D1"), xlAscending
    Cells(1, 5) = ""
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Kod: 
Sub AYNILARI_BUL_RENKLENDİR2()
    Dim Say As Long, X As Long, Y As Long, Son As Long, Satir As Long, Zaman As Double

    Zaman = Timer

    Range("A:D").Interior.ColorIndex = xlNone
    Range("C:D").ClearContents

    Son = Cells(Rows.Count, 1).End(3).Row
    Range("C1") = 1
    Range("C1").AutoFill Destination:=Range("C1:C" & Son), Type:=xlFillSeries

    Dim con As Object, rs As Object, sorgu As String
    Set con = CreateObject("adodb.Connection")
    Set rs = CreateObject("adodb.recordset")
    con.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
             ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=NO"""

    sorgu = "select (F1=F2) FROM [SHEET1$] "

    rs.Open sorgu, con, 1, 1
    Range("d1").CopyFromRecordset rs
    rs.Close
    Set rs = Nothing: Set con = Nothing: sorgu = ""

    Range("A1:D" & Son).Sort Range("D1"), xlAscending, Range("C1"), , xlAscending, , , xlNo
    Set ara = Range("D1:D" & Son).Find(What:="0", LookIn:=xlValues, LookAt:=xlWhole)
    If Not ara Is Nothing Then
        Range("a1:d" & ara.Row - 1).Interior.ColorIndex = 3
    End If

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Şimdi daha da hızlandırdım...

Kod: 
Option Explicit

Sub BENZERLERİ_BUL_RENKLENDİR()
    Dim Son As Long, Zaman As Double, Dizi As Variant, X As Long
    
    Zaman = Timer
    
    Range("A:B").Interior.ColorIndex = xlNone
    Range("C:D").ClearContents
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Range("C1") = 1
    Range("C1").AutoFill Destination:=Range("C1:C" & Son), Type:=xlFillSeries

    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dizi = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 4).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Dizi, 1)
            .Item(Dizi(X, 1)) = Dizi(X, 3) & "#" & Dizi(X, 1)
        Next
        
        Dizi = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 4).Value
        
        For X = 1 To UBound(Dizi, 1)
            If .Exists(Dizi(X, 2)) Then
                Dizi(X, 4) = Val(Split(.Item(Dizi(X, 1)), "#")(0))
            Else
                Dizi(X, 4) = ""
            End If
        Next
    End With
    
    Range("A1:D" & Son) = Dizi
    Range("A1:D" & Son).Sort Range("D1"), xlAscending
    Son = Cells(Rows.Count, 4).End(3).Row
    Range("A1:B" & Son).Interior.ColorIndex = 3
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Veyselemre ve Korhan Hocam elinize sağlık tam istediğim gibi çok işime yaradı.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst