Do-While Loop Mükerrer Kayıt Hakkında

[sserhat]

Merhaba,

Bir dosya üzerinde çalışıyorum. B sütununda mükerrer isimler var ben bu tekrar eden kayıtları tek satırda aynı kişinin farklı verilerini birleştiriyorum. Birleştirme bitince otomatik olarak o satırı siliyorum.

Sorunum Şu Mükerrer kayıt bitince bu kez sistem tek isimde olan kişinin satırını da silmeye başlıyor. Sizden isteğim Do while loop döngüsüyle tekrarı olmayan bir değer kalıncaya kadar silme işlemi yaptırabilecek bir makro var mı?

Ya da yapılabilecek farklı bir yöntem var mı?

Herkese kolay gelsin.

 

[asi_kral]

Merhaba
Örnek dosya ekler misiniz ?

 

[sserhat]

İlginiz için teşekkür ederim. Aslında yapmak istediğim tek tuşa basınca tüm dosyayı bitirmesi ama...Tek tek butona basınca işlemi yapabiliyorum. Bunun için call komutu kullanınca da bu kez tek isim bile kalsa silmeye başlıyor.

http://s8.dosya.tc/server2/3f1zgw/Son_Calisma.rar.html

 

[asi_kral]

Burada tam olarak istediğiniz nedir. Örnek vermemişsiniz ?

 

[sserhat]

Örnek dosyada mesela aynı isimdeki kişinin izinli olan günleri farklı farklı tarihlerde....Butona basınca
serhat Yİ-Yİ-Yİ
serhat ------------------------- Yİ-Yİ-Yİ

gibi farklı tarihlerdeki izinleri tek satırda birleştiriyor..

serhat Yİ-Yİ-Yİ ---------------------------- Yİ-Yİ-Yİ

şeklinde....
Elimde böyle uzun bir liste var bazı isimler 2-3 defa tekrar ederken bazı isimler tek sefer yazılmış....Yapmaya çalıştığım butona basınca aynı isimde olanların farklı izin günlerini tek satırda birleştirmek. Zaten ismi bir defa yazılanlarda bişey yapmadan devam edecek. En sonunda her isimden 1 tane kalacak ve o kişilerin bilgileri tek satırda olacak

 

[asi_kral]

Merhaba
Bu kodu dener misiniz ?

Sub birleştir()
Dim STR As Long, BUL As Range, SBT As Variant, BŞL As Variant
Application.DisplayAlerts = False
BŞL = ActiveCell.Address
For STR = 2 To Cells(Rows.Count, "B").End(xlUp).Row
If WorksheetFunction.CountIf(Range("B2:B" & STR), Cells(STR, "B")) = 1 Then
Set BUL = Range("B:B").Find(Cells(STR, "B"), , , xlPart)
If Not BUL Is Nothing Then
SBT = BUL.Address
Do
Range("D" & BUL.Row & ":AH" & BUL.Row).Copy
Cells(STR, "D").PasteSpecial xlPasteAll, xlNone, True, False
Application.CutCopyMode = False
Set BUL = Range("B:B").FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> SBT
End If
Else
Rows(STR).ClearContents
End If
Next
Range("B1:B" & STR - 1).AutoFilter 1, "="
Range("B2:B" & STR - 1).Delete
Range("B1:B" & STR - 1).AutoFilter
Range(BŞL).Select
Application.DisplayAlerts = True
End Sub

 

[veyselemre]

Alternatif,

Sub TEST()
    For i = Cells(Rows.Count, 1).End(3).Row To 3 Step -1
        For ii = i - 1 To 2 Step -1
            If Cells(i, 2).Value = Cells(ii, 2).Value Then
                For iii = 4 To 34
                    If Cells(i, iii).Value <> "" And Cells(ii, iii).Value = "" Then
                        Cells(ii, iii).Value = Cells(i, iii).Value
                    End If
                Next iii
                Rows(i).Delete
            End If
        Next ii
    Next i
End Sub

 

[sserhat]

Süpersiniz, elinize emeğinize sağlık iki kod da çok güzel çalışıyor...Allah razı olsun arkadaşlar. Selam ve dua ile

 

[sserhat]

Kusura bakmayın olduğunu sanmıştım ama şöyle bir sorun var sayın asi_kral ın yazmış olduğu kodda son satırdakini sorunsuz birleştiriyor fakat üst satırlarda sorun var en alt satırı üste alırken üsteki satırı siliyor. Bir de elimdeki dosyada bazı isimler 3 kez tekrar edilmiş bu durumda da sorun oluyor. İzin/rapor vs takip dosyası olduğu için aynı eleman 4-5 farklı izin rapor vs almış olabilir dolayısıyla da 4-5 kez adı tekrar ediyor olabilir.

Zor ve sıkıntılı bir dosya hakkınızı helal edin altından kalkamadım. Bu site sayesinde kendimizi geliştirmeye çalışıyoruz. Hepiniz sağolun.

 

[sserhat]

http://s6.dosya.tc/server6/9353la/Kitap_1.rar.html

Orijinal haliyle dosyayı yükledim.

 

[Korhan Ayhan]

Eklediğiniz dosyaya görmek istediğiniz sonucu da ekleyebilir misiniz?

 

[sserhat]

http://s8.dosya.tc/server2/rblszz/Kitap_1.rar.html

Yükledim Korhan Bey, ilginiz için teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub İZİNLERİ_BİRLEŞTİR()
    Dim X As Long, Y As Byte, Son As Long
    Dim Say As Long, Bul As Range, Adres As String
    
    Application.ScreenUpdating = False

    Son = Cells(Rows.Count, 1).End(3).Row
    
    For X = 2 To Son
        If Cells(X, 4) <> "" Then
            Say = WorksheetFunction.CountIf(Range("D:D"), Cells(X, 4))
            If Say > 1 Then
                Say = Say - 1
                Set Bul = Range("D:D").Find(Cells(X, 4), , , xlWhole)
                If Not Bul Is Nothing Then
10                  Adres = Bul.Address
                    If Adres <> Cells(X, 4).Address Then
                        Do
                            If Cells(Bul.Row, 5) <= Cells(X, 5) Then
                                Cells(X, 5) = Cells(Bul.Row, 5)
                                Cells(X, 1) = Day(Cells(X, 5))
                            End If
                            If Cells(Bul.Row, 6) >= Cells(X, 6) Then
                                Cells(X, 6) = Cells(Bul.Row, 6)
                                Cells(X, 2) = Day(Cells(X, 6))
                            End If
                            Cells(X, 7) = Cells(X, 7) + Chr(10) & Cells(Bul.Row, 7)
                            Cells(X, 8) = Cells(X, 8) + Cells(Bul.Row, 8)
                        
                            For Y = 9 To 39
                                If Cells(X, Y) = " " Then
                                    If Cells(Bul.Row, Y) <> " " Then
                                        Cells(X, Y) = Cells(Bul.Row, Y)
                                        Cells(Bul.Row, Y).Interior.ColorIndex = 6
                                    End If
                                End If
                            Next
                            Bul.EntireRow.ClearContents
                            Say = Say - 1
                            If Say = 0 Then Exit Do
                            Set Bul = Range("D:D").FindNext(Bul)
                        Loop While Not Bul Is Nothing And Bul.Address <> Adres
                    Else
                        Set Bul = Range("D:D").FindNext(Bul)
                        GoTo 10
                    End If
                End If
            End If
        End If
    Next

    On Error Resume Next
    Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    Cells.VerticalAlignment = xlCenter
    Cells.EntireColumn.AutoFit

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ziynettin]

Alternatif,

Sub izin_birlestir()
Set d = CreateObject("Scripting.Dictionary")
Set S1 = Sheets("Sayfa1")
Dim b()
a = S1.Range("A2:AM" & S1.Cells(Rows.Count, 1).End(3).Row)
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
sat = 1
Say = sat
    For i = 1 To UBound(a)
        krt = a(i, 3) & a(i, 4)
        If d.exists(krt) Then
            sat = d(krt)
        Else
            d(krt) = Say
            sat = Say
            Say = Say + 1
            For Y = 1 To 7
                b(sat, Y) = a(i, Y)
            Next Y
            For Y = 9 To UBound(a, 2)
                If a(i, Y) <> "" Then
                    b(sat, Y) = (a(i, Y))
                End If
            Next Y
         End If
            b(sat, 8) = b(sat, 8) + a(i, 8)
    Next i
    If d.Count > 0 Then
        S1.Range("A2:AM" & Rows.Count).ClearContents
        S1.[A2].Resize(d.Count, UBound(a, 2)) = b
    End If
    MsgBox "İşleminiz Bitti.....!", vbInformation
End Sub

 

[sserhat]

Harikasınız...Emeğinize sağlık 2 kod da süper...Korhan abi nin yaptığında ayrıca ücretsiz izin ve birleşen Ölüm İzni vs bilgisi aynı hücrede 2. satır olarak birleşmesi çok faydalı olmuş. Ben o kısmı düşünmemiştim.

Ziynettin Bey, size de ilginiz için teşekkür ederim...

Son olarak ben Türkçe öğretmeniyim programlamaya yeni başladım sayılır kodları biraz çözüp düzenleme yapabiliyorum, biraz da yazabiliyorum ama çok az, sizin gibi üstatlar gibi ilerletmek istiyorum. Ne yapmamı önerirsiniz?

 

[Korhan Ayhan]

Merhaba,

Ben Ziynettin beyin önerdiği kodu denedim. İsimleri teke düşürüyor fakat izinleri birleştirmedi. Sadece ilk satırdaki isimler listede kaldı. Sanırım ek düzenleme yapılması gerekiyor.

Exceli ileri seviye kullanabilmeniz için en azında temel fonksiyonları ileri derecede kullanabilmeniz size fayda sağlayacaktır. Bu seviyeyi geçtiyseniz makrolara adım atabilirsiniz. Bunun için nette satılan yardımcı kitapları satın alarak işe başlayabilirsiniz. Ayrıca ek olarak forumumuzun dersane bölümündeki konuları inceleyerek bilgilerinizi pekiştirebilirsiniz. Takıldığınız noktalarda foruma soru sorarak yardım isteyebilirsiniz.

Şimdiden size kolay gelsin.

 

[sserhat]

İlginiz için teşekkür ederim... Altın üye olarak ilk adımı attım sitedeki video dersleri sürekli takip edeceğim... İyi ki varsınız İyi ki böyle bir site var... Herkese kolaylıklar ve başarılar diliyorum