Sütundaki aynı değerler için bir işlem

[eemkadir]

Merhabalar,

Sütundaki aynı değerlerin karşısındaki bilgileri yan yana yazdırmak istiyorum. Ekte örnek mevcut, Yardımcı olabilir misiniz?

 

[apocalyt]

aşağıdaki kodu bir modüle kopyalayıp çalıştırın.

Sub daylight()
Application.ScreenUpdating = False
Sheets(2).Range("a2:f1000").ClearContents
For x = 1 To Sheets(1).[a10000].End(3).Row
For y = x + 1 To Sheets(1).[a1000].End(3).Row
If Sheets(1).Cells(x, 1) = Sheets(1).Cells(y, 1) Then
sayac = sayac + 1
Else
GoTo gel
End If
Next y
gel:
Sheets(1).Cells(x, 1).Copy
Sheets(2).Cells(Sheets(2).[a1000].End(3).Row + 1, 1).PasteSpecial
Sheets(1).Range("b" & x & ":b" & sayac + x).Copy
Sheets(2).Cells(Sheets(2).[b1000].End(3).Row + 1, 2).PasteSpecial Transpose:=True
x = x + sayac
sayac = 0
Next x
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[eemkadir]

Yardımınız için teşekkür ederim fakat bu kodları çalıştırdığımda ikinci sayfaya ilk iki sutunu işlem yapmadan direkt olarak atıyor.

 

[apocalyt]

sayın emmkadir..ikinci sayfadaki bütün verileri silin..sonra kodu çalıştırın..ilk satırı boş bırakıcak..oraya başlıklarınızı yazarsınız..yani sorun yok gözüküyo bende...yanlız ikinci sayfadaki verileri silmeden çalıştırdıysanız benim yazdığım kod ikinci sayfanın ilk satırını hiç silmez..orada başlıklarınız olur düşüncesiyle..kodu çalıştırıncada aynı satırdan iki defa gördünüz normal olarak..dedğim gibi kod doğru çalışıyor..kolay gelsin..

 

[eemkadir]

apocalyt haklısınız sorun bende imiş çalıştı, yardımınız için çok teşekkür ederim.