aynı olan satırları sütunlara yazdırmak

[regdtee]

merhaba,

A sütunundaki sayıların karşısında (B sütununda) farklı değerler var.yapmaya çalıştığım A Sütununda birden fazla aynı değer varsa A Sütununu tek bırakıp alt alta olan değerleri C, D, E .. Stünlarına yazdırmak.

5 a
5 b
2 a
2 b
2 c

örnek vermek gerekirse yukardaki verileri aşağıdaki gibi dağıtmak istiyorum.
yardımlarınız için şimdiden teşekkür ederim.

5 a b
2 a b c

 

[kemalist]

merhaba,

A sütunundaki sayıların karşısında (B sütununda) farklı değerler var.yapmaya çalıştığım A Sütununda birden fazla aynı değer varsa A Sütununu tek bırakıp alt alta olan değerleri C, D, E .. Stünlarına yazdırmak.

5 a
5 b
2 a
2 b
2 c

örnek vermek gerekirse yukardaki verileri aşağıdaki gibi dağıtmak istiyorum.
yardımlarınız için şimdiden teşekkür ederim.

5 a b
2 a b c

yukarıdan aşağı kopyala yapıştırmak istediğin hücreye sağ tıkla özel yapıştır-tersine çevir -tamam
hepsi bu kadar

 

[kemalist]

şekille anlatımlı örnek dosya ektedir.

 

[regdtee]

özel yapıştırı biliyorum.yapmak istediğim işlemi terisine çevirmek değil sadece, yani şöle bir şey yapmak istiyorum;

isimleri A Sütunu, soy isimleri B stünu kabul edersek

"A" "B"
Ahmet Akman
Ahmet Sever
Ahmet Cantürk
Mehmet Güneş
Mehmet Kemal

yukardaki verileri aşağıdaki hale cevirmek istiyorum;

"A" "B" "C" "D"
Ahmet Akman Sever Cantürk
Mehmet Güneş Kemal

yani A sütunu teke indirip Diğer verileri Yan sütuna almak istiyorum.

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz..

Option Explicit
 
Sub Duzenle()
Dim i As Long, j As Integer, c As Range, Addr As String
Range("D:IV").ClearContents
 
j = 0
For i = 1 To [A65536].End(3).Row
   If Application.WorksheetFunction.CountIf(Range("D:D"), _
   Cells(i, "A")) = 0 Then
      j = j + 1
      Cells(j, "D") = Cells(i, "A")
   End If
Next i
 
For i = 1 To [D65536].End(3).Row
   j = 4
   With Range("A:A")
       Set c = .Find(Cells(i, "D"), LookIn:=xlValues, LookAt:=xlWhole)
       If Not c Is Nothing Then
           Addr = c.Address
           Do
               j = j + 1
               Cells(i, j) = Cells(c.Row, "B")
               Set c = .FindNext(c)
           Loop While Not c Is Nothing And c.Address <> Addr
       End If
   End With
Next i
End Sub

.

 

[regdtee]

çok teşekkür ederim tam istediğim şey