İl,ilçe,isim,soyisim aynı olan satırları birleştirme

[bayhekim81]

İl,ilçe,isim,soyisim aynı olup; telefon,mail bilgileri arklı olan verileri birleştirme. Not: telefon yada mail sütununda farklı değerler var ise farklı olan veriler Tel2 ve Mail2 sütununa işlenmesi otomatik yapılabilir mi?

 

[bayhekim81]

Makro olmadan daha basit pratik hazır bir yolu varsa daha da iyi olur. ( farklı varyasyonlarda da kullanabilmek amacıyla ) veriler onbinlerce olduğu için tek tek yapmak çok fazla gereksiz zaman kaybı olurdu...

 

[cicosz]

Merhaba,
Forumda daha önce @Korhan Ayhan tarafından mükerrer kayıtlarla ilgili oluşturulan, benim de sıkça kullandığım kodu sizin örnek verilere göre revize edince ekteki dosyayı oluşturabildim. Birleştir butonu yardımıyla "Sayfa1"deki mükerrer veriler "Rapor" adlı sayfaya tekil olarak kaydediliyor.
Umarım işinize yarar.

 

[bayhekim81]

Malesef olmuyor --> iki telefon yada mail adresi olduğunda, bunları tek hücre içinde (aralarına herhangi bir ayraç koymadan) birleştiriyor. Halbuki ben bunların telefon2 ve mail2 kısmına ayrılmasını istemiştim

 

[bayhekim81]

Malesef olmuyor --> iki telefon numarasını birleştirmeye çalışırken birini bozuyor

 

[cicosz]

Merhaba,
İsteğiniz yönünde biraz değişiklikler yaparak ekteki 2 farklı senaryoyu oluşturdum. Sizin istediğiniz muhtemelen v2 adıyla başlayan dosyada. Dener misiniz?

 

[bayhekim81]

v'Kitap1birlestie.xlsm çalıştı teşekkürler, son işlem olarak Tel1 Tel2 Mail1 Mail2 de oluşan mükerer kayıtlarıda kaldırabilir mi?

 

[cicosz]

Merhaba,
Buton öncelikle E ve F sütunundaki tekrarlayan kayıtları bulur ve o hücrelerin içeriğini temizler, ardından daha önceden yapmış olduğumuz satır birleştirme işlemini yapar. Dener misiniz?

 

[bayhekim81]

Çalışıyor ayakta alkışlıyorum çok sağolun

 

[Korhan Ayhan]

Bu da alternatif olsun.

Hız olarak biraz daha avantaj sağlar.

Option Explicit

Sub Birlestir()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Kriter As String, Veri As Variant, Zaman As Double
    Dim X As Long, Son As Long, Say As Long, Y As Byte
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Rapor")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.ListObjects("Tablo1").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Veri = S1.Range("A1:H" & Son)
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 8)
    
    For X = 1 To UBound(Veri, 1)
        Kriter = Veri(X, 1) & "#" & Veri(X, 2) & "#" & Veri(X, 3) & "#" & Veri(X, 4)
        If Not Dizi.Exists(Kriter) Then
            Say = Say + 1
            Dizi.Add Kriter, Say
            For Y = 1 To 8
                Liste(Say, Y) = Veri(X, Y)
            Next
        Else
            If Liste(Dizi.Item(Kriter), 5) = "" Then
                Liste(Dizi.Item(Kriter), 5) = Veri(X, 5)
            Else
                If Liste(Dizi.Item(Kriter), 7) = "" Then
                    Liste(Dizi.Item(Kriter), 7) = Veri(X, 5)
                End If
            End If
            If Liste(Dizi.Item(Kriter), 7) = "" Then
                Liste(Dizi.Item(Kriter), 7) = Veri(X, 7)
            Else
                If Liste(Dizi.Item(Kriter), 5) = "" Then
                    Liste(Dizi.Item(Kriter), 5) = Veri(X, 7)
                End If
            End If
            
            If Liste(Dizi.Item(Kriter), 6) = "" Then
                Liste(Dizi.Item(Kriter), 6) = Veri(X, 6)
            Else
                If Liste(Dizi.Item(Kriter), 8) = "" Then
                    Liste(Dizi.Item(Kriter), 8) = Veri(X, 6)
                End If
            End If
            If Liste(Dizi.Item(Kriter), 8) = "" Then
                Liste(Dizi.Item(Kriter), 8) = Veri(X, 8)
            Else
                If Liste(Dizi.Item(Kriter), 6) = "" Then
                    Liste(Dizi.Item(Kriter), 6) = Veri(X, 8)
                End If
            End If
            If Liste(Dizi.Item(Kriter), 5) = Liste(Dizi.Item(Kriter), 7) Then Liste(Dizi.Item(Kriter), 7) = ""
            If Liste(Dizi.Item(Kriter), 6) = Liste(Dizi.Item(Kriter), 8) Then Liste(Dizi.Item(Kriter), 8) = ""
        End If
    Next
    
    S2.Range("A:H").Clear
    S2.Range("A1").Resize(Say, 8) = Liste
    S2.Cells.EntireColumn.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub