Aynı Değer Karşılıklarını Yan Yana Yazdırma

[dmitri]

Arkadaşlar Merhaba,

İşin içinden çıkamadığım bir sorunum var. Mükerrer verilerin olduğu bir kolonum var. Örneğin A1 hücresinden A10 hücresine kadar 1,1,1,2,2,3,3,4,5,5 şeklinde ID ler olsun. Bu ID ler karşılığında yani B kolonunda bu ID lere ait telefon numaraları var. Telefon numaralarının hepsi farklı. Ancak 1 ID sine ait 3 telefon numarası mevcut.

Benim yapmak istediğim işlem, öyle bir formül (ya da makro) kullanayım ki mükerrer kayıtlar bir sütuna benzersiz olarak alınsın, (yani 1,2,3,4,5 şeklinde) karşılıkları da aynı satırda B,C ve devam ediyorsa D,E kolonlarına yazılsın. Pivot Table ile yapamadım.

Örnek veri bu:

ID TEL
1 123
1 234
1 345
2 456
2 567
3 678
3 789
3 900
4 1011
4 1122
4 1233
4 1344
5 1455
6 1566


Olmasını istediğim:

ID TEL1 TEL2 TEL3 TEL4
1 123 234 345
2 456 567
3 678 789 900
4 1011 1122 1233 1344
5 1455
6 1566


Yardımlarınız için şimdiden çok teşekkürler.

 

[Ali]

Formül ile biraz uzun olabilir ama fonksiyonla bir örnek hazırladım.

 

[Necdet]

Merhaba,

Makrolu çözüm hazırlamıştım, Sayfa2 de sonuç gösterilir.

Sub Duzenle()
Dim i As Long
Dim j As Integer, Kol As Integer
Dim s1 As Worksheet, s2 As Worksheet
Dim EskiDeger As String
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Select
For i = 2 To s1.[A65536].End(3).Row
    If s1.Cells(i, "A") <> EskiDeger Then
        EskiDeger = s1.Cells(i, "A")
        j = j + 1
        Kol = 1
        Cells(j, Kol) = s1.Cells(i, "A")
    End If
    Kol = Kol + 1
    Cells(j, Kol) = s1.Cells(i, "B")
Next i
End Sub

 

[mustafaine1]

yaptigim calisma isinizi gorurmu acaba..

 

[dmitri]

Arkadaşlar, harikasınız! Makrolu çözüm işimi çok kolaylaştıracak. Formüllü çözümler için de çok teşekkür ederim. Diğer bir projemde makro kullanamıyorum. Formülleri ona uygulayacağım. Anlaşılan o ki benim şu dizi formülleri iyice öğrenmem lazım... Tekrar teşekkürler!

 

[Recep İpek]

Bir alternatif de benden olsun. Belki birilerinin işine yarayabilir...

[COLOR=black][FONT=Courier New]Sub Rapor()[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]On Error Resume Next[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]Dim veri(), w[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]Set s1 = Sheets("Sayfa1")[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]Set s2 = Sheets("Sayfa2")[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]'*************************************************************[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]a = s1.Range("a2:b" & s1.[a65536].End(3).Row).Value[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]ReDim veri(1 To UBound(a, 1), 1 To 20)[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]'*************************************************************[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]With CreateObject("Scripting.Dictionary")[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]   .CompareMode = vbTextCompare[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]   For i = 1 To UBound(a, 1)[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]       If Not .exists(a(i, 1)) Then[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]           n = n + 1[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]           .Add a(i, 1), Array(n, 1)[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]           veri(n, 1) = a(i, 1)[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]       End If[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]          w = .Item(a(i, 1))[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]          w(1) = w(1) + 1[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]          veri(w(0), w(1)) = a(i, 2)[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]          .Item(a(i, 1)) = w[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]         maxCol = Application.Max(maxCol, w(1))[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]    Next i[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]End With[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]'**************************************************************[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]s2.Range("a2:b1000").ClearContents[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]s2.[a2].Resize(n, maxCol).Value = veri[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]s2.Select[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]''*************************************************************[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]MsgBox "Bitti"[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]Set s1 = Nothing[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]Set s2 = Nothing[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]End Sub[/FONT][/COLOR]