otomatik olarak farklı satırlardaki aynı verileleri tek satıra birleştirmek

[__varyemez_-]

Selamlar arkadaşlar. personel kayıtlarını ve ödeme sistemlerini excel de tutuyorum. yeni veri ekleyeceğim zaman değeri bulup yeninden yazmak çok zamanımı alıyor. amacım bunu hızlı bir şekilde yapabilmek.
A1 AD B1 SOYAD C1 TC D1 E1
A5:AHMET B5FARUK C5 58617598621 D5 40 E5: 80
.........................................................................................
A21:AHMET B21:FARUK C21 58617598621 F21: 50 H21:75

verilerin bu şekilde olduğunu düşünürsek. Benim amacım seçtiğim bir sütun üzerinden öreniğin "C" aynı olanları bulup aşağıdaki gibi birleştirmesi

A5:AHMET B5:FARUK C5:58617598621 D5:40 E5:80 F5:50 G5: (BOŞ) H5:75

YARDIMCI OLURSANIZ SEVİNİRİM

 

[Ömer]

Merhaba,

Aşağıdaki kodları deneyin. Yeşil ile yazdığım açıklama kısımlardaki sayfa isimlerini kendi dosyanıza uygun olarak değiştirebilirsiniz.

Sub Doldur_Yaz()
 
    Dim d As Object, S2 As Worksheet, sut As Integer
    Dim i As Long, j As Byte, deg, s, a1
 
    Set d = CreateObject("Scripting.Dictionary")
    Set S2 = Sheets("[COLOR="Red"]Sayfa2[/COLOR]") [COLOR="DarkGreen"]'sayfa2 ye istediğiniz formata uygun yazar.[/COLOR]
 
    Application.ScreenUpdating = False
    Sheets("[COLOR="Red"]Sayfa1[/COLOR]").Select[COLOR="DarkGreen"] 'sayfa1 deki bilgileri[/COLOR]
    sut = Cells(1, Columns.Count).End(xlToLeft).Column

    For i = 1 To Cells(Rows.Count, "C").End(xlUp).Row
        deg = Cells(i, "C")
        If Not d.exists(deg) Then
            ReDim s(1 To sut)
            For j = 1 To sut
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 1 To sut
                If s(j) = "" Then
                    s(j) = s(j) & Cells(i, j)
                End If
            Next j
            d.Item(deg) = s
        End If
    Next i
    
    Sheets("Sayfa2").Select
    Cells.ClearContents
    
    a1 = d.items
    For i = 0 To d.Count - 1
        s = a1(i)
        For j = 1 To sut
            Cells(1 + i, j) = s(j)
        Next j
    Next i
    
    Application.ScreenUpdating = True

End Sub

.