Aynı İsimde Olan Alt Satırları Birleştir

[meslek5]

Merhaba değerli üstatlar;
Linkte yer alan ÖRNEK.xlsb isimli dosyada alt alta satırlarda olan isimleri seçerek hücre birleştirmesi yapmak istiyorum. Butona bastığımda alt alta satırlarda olan aynı isimleri bulup o satırları birleştirecek. Bunu makro kodu ile yapmak istiyorum. Olabilirliği mümkün ise yadımcı olacaklara şimdiden teşekkür ederim.

İndir ÖRNEK xlsb (dosya.co)

 

[zpawnz]

Merhaba,

Tablonuzu seçip Veri / Yinelenenleri Kaldır ile birleştirmenize gerek kalmadan sade veriyi elde edebilirsiniz.

 

[meslek5]

Merhaba,

Tablonuzu seçip Veri / Yinelenenleri Kaldır ile birleştirmenize gerek kalmadan sade veriyi elde edebilirsiniz.

Birleştirme yapmam gerekiyor. Çünkü tabloda aynı kişilerin karşısında farklı veriler yer alıyor

 

[veyselemre]

Sub test()
    Dim i, bas, son, veri
    bas = 0
    Application.DisplayAlerts = False
    For i = 13 To Cells(Rows.Count, "D").End(3).Row
        If veri = Join(WorksheetFunction.Index(Cells(i, "D").Resize(, 3).Value, 0), "_") Then
            If bas = 0 Then
                bas = i: son = i
            Else
                son = i
            End If
        Else
            If son > bas Then
                Range("D" & bas & ":D" & son).Merge
                Range("E" & bas & ":E" & son).Merge
                Range("F" & bas & ":F" & son).Merge
            End If
            veri = Join(WorksheetFunction.Index(Cells(i, "D").Resize(, 3).Value, 0), "_")
            bas = i
        End If
    Next i
    Application.DisplayAlerts = True
End Sub

 

[zpawnz]

Merhaba,

Alnternatif, tablonuzun A:C aralığında olduğunu varsayarak

Sub MergeIdenticalCells()
Dim ws As Worksheet
Dim lastRow As Long
Dim r As Long
Dim col As Integer
Set ws = ActiveSheet
Application.DisplayAlerts = False
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For col = 1 To 3
r = 1
While r <= lastRow
If r < lastRow Then
If ws.Cells(r, col).Value = ws.Cells(r + 1, col).Value Then
Dim mergeStart As Long
mergeStart = r
While r < lastRow And ws.Cells(r, col).Value = ws.Cells(r + 1, col).Value
r = r + 1
Wend
ws.Range(ws.Cells(mergeStart, col), ws.Cells(r, col)).Merge
End If
End If
r = r + 1
Wend
Next col
Application.DisplayAlerts = True
End Sub

Deneyiniz.

 

[meslek5]

Sub test()
    Dim i, bas, son, veri
    bas = 0
    son = 0
    Application.DisplayAlerts = False
    For i = 13 To Cells(Rows.Count, "D").End(3).Row
        If veri = Join(WorksheetFunction.Index(Cells(i, "D").Resize(, 3).Value, 0), "_") Then
            If bas = 0 Then
                bas = i: son = i
            Else
                son = i
            End If
        Else
            veri = Join(WorksheetFunction.Index(Cells(i, "D").Resize(, 3).Value, 0), "_")
            If son > bas Then
                Range("D" & bas & ":D" & son).Merge
                Range("E" & bas & ":E" & son).Merge
                Range("F" & bas & ":F" & son).Merge
            End If
            veri = Join(WorksheetFunction.Index(Cells(i, "D").Resize(, 3).Value, 0), "_")
            bas = i
        End If
    Next i
    Application.DisplayAlerts = True
End Sub

Hocam çok teşekkür ederim tam istediğim sonucu veriyor. Elinize emeğinize sağlık.

 

[meslek5]

Sub test()
    Dim i, bas, son, veri
    bas = 0
    Application.DisplayAlerts = False
    For i = 13 To Cells(Rows.Count, "D").End(3).Row
        If veri = Join(WorksheetFunction.Index(Cells(i, "D").Resize(, 3).Value, 0), "_") Then
            If bas = 0 Then
                bas = i: son = i
            Else
                son = i
            End If
        Else
            If son > bas Then
                Range("D" & bas & ":D" & son).Merge
                Range("E" & bas & ":E" & son).Merge
                Range("F" & bas & ":F" & son).Merge
            End If
            veri = Join(WorksheetFunction.Index(Cells(i, "D").Resize(, 3).Value, 0), "_")
            bas = i
        End If
    Next i
    Application.DisplayAlerts = True
End Sub

Hocam çok teşekkür ederim. kod tam istediğim gibi fakat, F sütunundaki veriler alt alta aynı değilse birleştirme işlemi yapmıyor.
birde son satırın altında tablo altı bilgileri mevcut ve o satırları da altındaki satırlarla birleştiriyor ama o satırlara dokunmaması gerekiyor. Son olarak sıra noyu birleştirilmiş hücrelerde ardışık sıralayabilir miyiz.
NOT: ÖRNEK DOSYAYI YENİLEDİM

İndir ÖRNEK YENİ xlsb

Dosyayı indir ÖRNEK YENİ xlsb

dosya.co

 

[RBozkurt]

D, E, ve F sütunlarında 3 işlevli verileri sıralama yapın, makro kaydet ile çözersiniz. Arkasına yukarıdaki makroyu çalıştırın.
Tüm hepsi kendi içinde sıralanır ve Birleşmiş olur.

 

[meslek5]

RBozkurt hocam bahsi geçen sütunlardaki benzer isimler her ay çoğalabilir ve azabilir. Yani #veyselemre hocamın vermiş olduğu kodda değişiklik yapılarak çözülebilir diye düşünüyorum. Ben bayağı uğraştım ama iyice karıştı.

 

[veyselemre]

Sub test()
    Dim i, bas, veri, sn
    Application.DisplayAlerts = False
    i = 15
    While IsNumeric(Cells(i, "B").Value) And Cells(i, "B").Value <> ""
        If veri <> Cells(i, "C").Value Then
            sn = sn + 1
            Cells(i, "B").Value = sn
            veri = Cells(i, "C").Value
            bas = i
        Else
            If i > bas And Cells(i + 1, "C").Value <> veri Then
                Range("B" & bas & ":B" & i).Merge
                Range("C" & bas & ":C" & i).Merge
                Range("D" & bas & ":D" & i).Merge
                Range("E" & bas & ":E" & i).Merge
            End If
        End If
        i = i + 1
    Wend
    Application.DisplayAlerts = True
End Sub

 

[meslek5]

Sub test()
    Dim i, bas, veri, sn
    Application.DisplayAlerts = False
    i = 15
    While IsNumeric(Cells(i, "B").Value) And Cells(i, "B").Value <> ""
        If veri <> Cells(i, "C").Value Then
            sn = sn + 1
            Cells(i, "B").Value = sn
            veri = Cells(i, "C").Value
            bas = i
        Else
            If i > bas And Cells(i + 1, "C").Value <> veri Then
                Range("B" & bas & ":B" & i).Merge
                Range("C" & bas & ":C" & i).Merge
                Range("D" & bas & ":D" & i).Merge
                Range("E" & bas & ":E" & i).Merge
            End If
        End If
        i = i + 1
    Wend
    Application.DisplayAlerts = True
End Sub

veyselemre hocam kod tam istediğim gibi çalışıyor. Ne kadar teşekkür etsem azdır. Allah senden razı olsun.