Çok İsimleri Tek'e Düşürme

[baba]

Merhaba;
Ekte Göndermiş olduğum. Çalışmada Birde Fazla İsimler Bulunmaktadır. Bunlar Sayfanın Sol Tarafına Tek İsim Haline Nasıl Getirebiliriz.Sağ Taraftakiler Değişmeden
Saygılarımla.

 

[askm]

Bir modul ekleyip aşağıdaki kodları yazın istediğiniz sanırım bu.

Sub mukerrerayikla()
For a = 1 To [b65536].End(3).Row
If WorksheetFunction.CountIf(Range("b2:b" & a), Cells(a, 2)) = 1 Then
'c = c + 1 'Bu satır hücreleri birleştirir.
Cells(a, 1) = Cells(a, 2)
End If
Next
End Sub

 

[baba]

Ellerinize Sağlık Teşekkürler. Çok Olmasa Eğer Bir İsteğimde Daha olacak Tek Gelen İsimleri Hücreleri birleştire bilirmiyiz? Ortalayarak

 

[askm]

'c = c + 1 'Bu satır hücreleri birleştirir.['code]
kodunun başındaki tırnak işaretinikaldırın.

 

[baba]

Kaldırım Değişmedi.

 

[Ömer]

Merhaba,

Alternatif olsun.

Sub Duzenle()

    Dim d As Object, i As Long, j As Long, deg
    
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    
    With Range("A:A")
        .MergeCells = False
        .ClearContents
    End With
    
    Range("B2:B" & Rows.Count).Sort Range("B2"), xlAscending

    For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            If i <> 1 Then
                Cells(j, "A").Resize(i - j, 1).MergeCells = True
            End If
            j = i
            d.Add deg, Nothing
            Cells(i, "A") = deg
        End If
    Next i
    
    Cells(j, "A").Resize(i - j, 1).MergeCells = True

    Application.ScreenUpdating = True
    
End Sub

.

 

[Ömer BARAN]

Merhaba.

Bir alternatif de benden olsun.
.

[FONT="Arial Narrow"][B]Sub mukerrerayikla()[/B]
With Range("A1:A" & [B65536].End(3).Row)
    .Borders.LineStyle = xlNone: .ClearContents: .UnMerge
        End With
            Set wf = Application.WorksheetFunction: Cells.UnMerge
                For a = 1 To [B65536].End(3).Row
                    If WorksheetFunction.CountIf(Range("B2:B" & a), Cells(a, 2)) = 1 Then
                        ilk = wf.Match(Cells(a, 2), Range("B:B"), 0)
                    son = wf.CountIf(Range("B:B"), Cells(a, 2)) + ilk - 1
                With Range(Cells(ilk, 1), Cells(son, 1))
            .Merge: .VerticalAlignment = xlCenter: .HorizontalAlignment = xlLeft
        End With: Cells(ilk, 1) = Cells(a, 2): a = son
    End If
Next: Range("A1:B" & [B65536].End(3).Row).Borders.LineStyle = xlContinuous
[B]End Sub[/B][/FONT]

 

[baba]

Çok teşekürler ederim. Ellerinize emeğinize sağlık.