Farklı Bir Mükerrer Kontrolü.

[leumruk]

Selamlar,
Belli bir aralıktaki verilerin başka bir aralıkta tekrar edip etmediğini kontrol edebilir miyiz? Yanlış anlaşılmasın, hücre kontrolü değil; blok halinde kontrol yapacak.
Açıklama ekte...
Saygılar...

 

[Mahmut Kök]

Selamlar,
Belli bir aralıktaki verilerin başka bir aralıkta tekrar edip etmediğini kontrol edebilir miyiz? Yanlış anlaşılmasın, hücre kontrolü değil; blok halinde kontrol yapacak.
Açıklama ekte...
Saygılar...

Doğrudan blok haline denetlemiyor ama aşağıdaki kod ile hücreler birebir karşılaştırılıyor. A sütunu ile C sütununu karşılaştıran örnek fikir verebilir.

Sub karşılaştır()
For a = 1 To 10
If Cells(a, "[COLOR=red]a[/COLOR]") <> Cells(a, "[COLOR=red]c[/COLOR]") Then
MsgBox "AYNI DEĞİL"
Exit Sub
End If
Next
MsgBox "aynı"
End Sub

 

[Ferhat Pazarçevirdi]

Bir alternatif de şöyle olabilir :

Aşağıdakileri, Standart bir modül sayfasına kopyalayıp çalıştırınız.

Sub Farklı_Sutunlari_Goster()
 
    Dim arrEsas() As Variant
    Dim arrDigr() As Variant
    Dim sEsas As String
    Dim sDigr As String
    Dim j As Integer
 
    sEsas = String_Olustur(1, arrEsas())
 
    For j = 2 To Cells(1, 256).End(xlToLeft).Column
 
        sDigr = String_Olustur(j, arrDigr())
 
        If StrComp(sEsas, sDigr, vbTextCompare) = 0 Then
            MsgBox "1.sütun ve " & j & ".sütun birbiri ile aynı ...", _
                        vbInformation, _
                            "Bilgilendirme"
        End If
 
    Next j
 
    Erase arrEsas:    Erase arrDigr
 
End Sub
[COLOR=darkgreen]'----------------------------------------------[/COLOR] 
Private Function String_Olustur(iSutn As Integer, arrDizi() As Variant) As String
    Dim i As Integer
 
    ReDim arrDizi(1 To Cells(65536, iSutn).End(xlUp).Row)
 
    For i = 1 To UBound(arrDizi)
        arrDizi(i) = Cells(i, iSutn)
    Next i
 
    String_Olustur = Join(arrDizi, ""),
 
End Function

 

[ersoyalan]

Ferhat hocam merhaba,

Kodları çalıştırınca ekli dosyadaki hatayı veriyor.

E.ALAN

 

[Korhan Ayhan]

Selamlar,

Sn. ersoyalan,

Ferhat beyin önerdiği kodda en alttan ikinci satırdaki son kısımdaki virgülü silerseniz hata düzelecektir.

String_Olustur = Join(arrDizi, "")[B][COLOR=red],[/COLOR][/B]

 

[ersoyalan]

Korhan hocam teşekkürederim.

E.ALAN

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki koduda kullanabilirsiniz.

Option Explicit
 
Sub MÜKERRER_SÜTUN_KONTROLÜ()
    Dim İLK As Date, SON As Date, SÜRE As Date
    Dim İLK_DİZİ As String, YENİ_DİZİ As String
    Dim X As Long, Y As Byte, Z As Long
    Dim SÜTUN As String
 
    İLK = Time
    For X = 1 To [A65536].End(3).Row
        İLK_DİZİ = İLK_DİZİ & Cells(X, 1)
    Next
 
    For Y = 2 To [IV1].End(1).Column
        For Z = 1 To Cells(65536, Y).End(3).Row
            YENİ_DİZİ = YENİ_DİZİ & Cells(Z, Y)
        Next
            If İLK_DİZİ = YENİ_DİZİ Then
                SÜTUN = IIf(SÜTUN = Empty, Y & ".", SÜTUN & " - " & Y & ".")
            End If
        YENİ_DİZİ = Empty
    Next
    SON = Time
    SÜRE = Format((SON - İLK), "hh:mm:ss")
    If SÜTUN = Empty Then
    MsgBox "Mükerrer kayıt bulunamamıştır !" & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
    ElseIf InStr(1, SÜTUN, "-") > 0 Then
    MsgBox SÜTUN & "  sütunlar mükerrer kayıt edilmiştir." & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
    Else
    MsgBox SÜTUN & ". sütun mükerrer kayıt edilmiştir." & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
    End If
End Sub

 

[leumruk]

Arkadaşlar, hepinize ayrı ayrı teşekkür ederim. Ellerinize sağlık...

 

[leumruk]

Arkadaşlar, bu tamam...
Bir de "A" sütununa göre değilde, tüm alana göre bir kod yazabilir miyiz? Yani belirtilen alanda herhangi iki sütunda veyafazlasında benzerlik varsa uyarı verebilir mi?

 

[ersoyalan]

Korhan hocam merhaba,

3-4-5 stun yerine c-d-e stunlar diye adlandırabilirmisiniz.Kontrol ettiğimiz stunların oldukça fazla olduğunu düşünürsek kangisinin kaçıncı stun olduğu bulmak zor olur.Hatta farklı olan mükerrer olmayan stunları renkliyebilirmisiniz.

E.ALAN

 

[Korhan Ayhan]

Selamlar,

Sn. ersoyalan,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub MÜKERRER_SÜTUN_KONTROLÜ()
    Dim İLK As Date, SON As Date, SÜRE As Date
    Dim İLK_DİZİ As String, YENİ_DİZİ As String
    Dim X As Long, Y As Byte, Z As Long
    Dim SÜTUN As String
 
    İLK = Time
    
    Cells.Interior.ColorIndex = xlNone
    
    For X = 1 To [A65536].End(3).Row
        İLK_DİZİ = İLK_DİZİ & Cells(X, 1)
    Next
 
    For Y = 2 To [IV1].End(1).Column
        For Z = 1 To Cells(65536, Y).End(3).Row
            YENİ_DİZİ = YENİ_DİZİ & Cells(Z, Y)
        Next
            If İLK_DİZİ = YENİ_DİZİ Then
                If SÜTUN = Empty Then
                   SÜTUN = Cells(1, Y).Address(0, 0)
                   Else
                   SÜTUN = SÜTUN & " - " & Cells(1, Y).Address(0, 0)
                End If
                SÜTUN = SÜTUN_HARFİ_AYIR(SÜTUN)
                Else
                Columns(Y).Interior.ColorIndex = 8
            End If
        YENİ_DİZİ = Empty
    Next
    
    SON = Time
    
    SÜRE = Format((SON - İLK), "hh:mm:ss")
    
    If SÜTUN = Empty Then
        MsgBox "Mükerrer kayıt bulunamamıştır !" & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
    ElseIf InStr(1, SÜTUN, "-") > 0 Then
        MsgBox SÜTUN & "  sütunları mükerrer kayıt edilmiştir." & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
    Else
        MsgBox SÜTUN & ". sütun mükerrer kayıt edilmiştir." & vbCrLf & "İşlem süresi  ; " & SÜRE, vbCritical
    End If
End Sub
 
Function SÜTUN_HARFİ_AYIR(SÜTUN As String) As String
    Dim RAKAM() As Variant, X As Integer
    
    RAKAM = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
    
    For X = 0 To UBound(RAKAM)
        If InStr(1, SÜTUN, RAKAM(X)) > 0 Then
        SÜTUN_HARFİ_AYIR = Replace(SÜTUN, RAKAM(X), "")
        Exit For
        End If
    Next
End Function

 

[ersoyalan]

Korhan hocam merhaba,

Kod mükemmel çalışıyor çok teşekkürederim.

Syg,

E.ALAN

 

[leumruk]

Bir de "A" sütununa göre değilde, tüm alana göre bir kod yazabilir miyiz? Yani belirtilen alanda herhangi iki sütunda veya fazlasında benzerlik varsa uyarı verebilir mi?