Sütunları Metne Çevirme Benzeri Bir Durum

[endersen]

Merhaba,

Sistem üzerinden aldığım iletişim raporunda bir kişiye kayıtlı telefon numaraları alt alta satır satır yazıyor. Bu satırlar değişken yani bazı kişilerde 2 telefon numarası bazı kişilerde 8 telefon numarası yazıyor.

Ben bu telefon numaralarını sütun sütun yan yana olsun istiyorum.

Sütunları metne çevir diye bir işlem bulamadım ancak manuel olarak kopyala - özel yapıştır - işlemi tersine çevir komutu ile yapabiliyorum. Liste çok kalabalık ve çok uzun buda fazla fazla zaman alıyor.

Pratik olarak yapabileceğim bir formül makro v.s. var mıdır acaba ?

Arzu ederseniz örnek liste gönderebilirim.

Şimdiden ilginiz için teşekkür ederim.

 

[Ömer]

Merhaba,

Mevcut durum olmasını istediğiniz durum olarak belirterek. Örnek bir dosya eklemenizi rica ederim.

www.dosya.tc

.

 

[endersen]

Merhaba,

Mevcut durum olmasını istediğiniz durum olarak belirterek. Örnek bir dosya eklemenizi rica ederim.

www.dosya.tc

.

Ömer Bey,

Dosya aşağıda paylaştığım likte yer almaktadır.

http://s8.dosya.tc/server5/bhwmft/Ender.xlsx.html

Sheet'lere orijinal ve olmasını istediğim tabloları ekledim.


Teşekkürler, iyi çalışmalar

 

[Ömer]

Bu şekilde deneyin.

Sub Duzenle()

    Dim d As Object, i As Long, s, deg, a1, a2, k, j As Integer

    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("Orijinal Liste").Select 'verilerin alınacağı sayfa

    For i = 2 To Cells(Rows.Count, "a").End(xlUp).Row
        deg = Cells(i, "A")
        If Not d.exists(deg) Then
            s = Array(Cells(i, "B"), Cells(i, "F"))
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(1) = s(1) & "|" & Cells(i, "F")
            d.Item(deg) = s
        End If
    Next i

    Sheets("Olmasını İstediğim Hali").Select 'verilerin listeleneceği sayfa
    Cells.ClearContents
    Range("A1").Resize(1, 3) = [{"Borçlu TCKN","Borçlu Adı Soyadı","TELEFON"}]
    Rows("1:1").Font.Bold = True
    
    a1 = d.keys: a2 = d.items
    For i = 0 To d.Count - 1
        s = a2(i)
        Cells(i + 2, "A") = a1(i)
        Cells(i + 2, "B") = s(0)
        k = Split(s(1), "|")
        For j = 0 To UBound(k)
            Cells(i + 2, j + 3) = k(j)
        Next j
    Next i
    
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

.

 

[endersen]

Ömer Bey,

Çok teşekkür ederim elinize emeğinize sağlık.