Kısmi Mükerrerliği tamamlamak...

[blackmonkey]

2. satırda a dışındaki b, c, d ve e hücreleri mükerrer ise a hücresinin de mükerrer olmasının sağlanmasını istiyorum. Böylece mükerrer kayıtları bir arada görmeği umuyorum. Daha doğrusu b, c, d ve e leri mükerrer olanların ilk a'daki no'yu almalarını istiyorum. Örnekle daha iyi anlatmış olabilirim. Saygılarımla...

 

[blackmonkey]

Ekini unutmuşum, özür dilerim...

2. satırda a dışındaki b, c, d ve e hücreleri mükerrer ise a hücresinin de mükerrer olmasının sağanmasını istiyorum. Böylece mükerrer kayıtları bir arada görmeği umuyorum. Örnekle daha iyi anlatmış olabilirim. Saygılarımla...

 

[Korhan Ayhan]

Selamlar,

Eğer amacınız mükerrer kayıtları tesbit etmekse aşağıdaki formülü kullanabilirsiniz.

F2 hücresine uygulayın. Ve aşağıya doğru sürükleyin.

=EĞER(TOPLA.ÇARPIM(--($B$2:$B$1000&$C$2:$C$1000&$D$2:$D$1000&$E$2:$E$1000=B2&C2&D2&E2))>1;"MÜKERRER";"")

 

[blackmonkey]

Sayın Hocam amacım mükerreri bulmak değil, mükerrerlerin başlangıç nosunu aynı yapmak ve a sütununu süzerek altalta getirmek. Örneğimize dönersek son satırı 2.satırın altına getirmek.

 

[muygun]

Merhaba;
Ayrı bir alanda bunu yapmak isterseniz eki inceleyin.
İyi çalışmalar.

 

[blackmonkey]

Tam olmadı...

Sayın Muygun, fazlaca süren gecikmem için özür dilerim. Fakat ben ayrı bir yerde yapmak istemiyorum. A hücresinde mükerrerlik sağlansın istiyorum. Sorunum çözümlenmediği için gündemde tutuyorum. İlgilenen Uzmanlara teşekkür ederim. Saygılarımla...

 

[Korhan Ayhan]

Selamlar,

A2 hücresine aşağıdaki formülü uygulayıp denermisiniz.

=EĞER($B2="";"";EĞER(EMETİNSE(DOLAYLI(ADRES(SATIR()-1;1)));1;EĞER(TOPLA.ÇARPIM(--($B$2:$B2&$C$2:$C2&$D$2:$D2&$E$2:$E2=$B2&$C2&$D2&$E2))>1;İNDİS($A$2:$A2;TOPLA.ÇARPIM((KAÇINCI($B2&"@"&$C2&"@"&$D2&"@"&$E2;$B$2:$B2&"@"&$C$2:$C2&"@"&$D$2:$D2&"@"&$E$2:$E2;0))));MAK($A$1:$A1)+1)))

 

[blackmonkey]

Teşekkürler

Sayın Korhan Bey, umutsuzluğa düştüğüm andı. Çok güzel oldu. Şimdi veriler az işimi görüyor. Veriler artınca kodunu isteyebilir. Konunun bütünlüğü açısından kodunu da yazbilirmisiniz? Olmazsa da teşekkür ederim. Sağolun...

 

[Korhan Ayhan]

Selamlar,

Zaten ilk mesajımdaki formülü önermemdeki sebepte buydu. Verileriniz arttıkça bu tarz formüller çalışmanıza engel olmaya başlayacaktır. Makrolu yöntem için sayfaya verileri girdikçe çalışan bir kodmu istersiniz? Yoksa bir buton aracılığı ile veri girişini tamamladıktan sonra çalışacak bir kodmu istersiniz?

 

[blackmonkey]

Sayın Korhan Ayhan, buton olmasın; veri girdikçe çalışan bir kod olsun diyorum. Ama çok ta mahcup oluyorum. Teşekkür etmek eksiklenmemi gidermedi. Sağolun...

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu sayfanızın kod bölümüne uygulayıp denermisiniz. B-C-D-E sütunlarına veri girişiniz tamamlandığında kod otomatik olarak çalışacaktır.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range, ADRES As String, KONTROL As Boolean
    
    On Error GoTo Son
    
    If Intersect(Target, [B2:E65536]) Is Nothing Then Exit Sub
    If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
    
    If WorksheetFunction.CountA(Range(Cells(Target.Row, 2), Cells(Target.Row, 5))) = 4 Then
    
        If WorksheetFunction.CountIf(Range("B1:B" & Target.Row), Target) = 1 Then
            Cells(Target.Row, 1) = WorksheetFunction.Max(Range("A1:A" & Target.Row - 1)) + 1
            GoTo Son
        End If
    
        Set BUL = Range("B1:B" & Target.Row - 1).Find(Cells(Target.Row, 2), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
            If Cells(BUL.Row, 3) = Cells(Target.Row, 3) And _
            Cells(BUL.Row, 4) = Cells(Target.Row, 4) And _
            Cells(BUL.Row, 5) = Cells(Target.Row, 5) Then
            Cells(Target.Row, 1) = Cells(BUL.Row, 1)
            KONTROL = True
            End If
        Set BUL = Range("B1:B" & Target.Row - 1).FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    
        If KONTROL = False Then
            Cells(Target.Row, 1) = WorksheetFunction.Max(Range("A1:A" & Target.Row - 1)) + 1
        End If
    
        End If
    End If
Son:
        Set BUL = Nothing
End Sub

 

[blackmonkey]

Teşekkür Ederim.

Sayın Korhan Ayhan, yazdığınız kod işimi gördü. Herşey daha kolaylaştı. Geciken teşekkürüm için özür diler, herşeyin gönlünüzce sağlık içinde olmasını dilerim. Saygılarımla...