Aynı Hücreleri Listeleme Sorunu

[fatihdemirel]

Aşağıdaki örnekte herşey açıkça görülüyor. Uzun bir isim listem var. Bir isim yazdığımda o isimdeki herkesi arada boşluklar olmadan listelesin istiyorum. Yardımınızı bekliyorum. Teşekkürler.

 

[İhsan Tank]

Aşağıdaki örnekte herşey açıkça görülüyor. Uzun bir isim listem var. Bir isim yazdığımda o isimdeki herkesi arada boşluklar olmadan listelesin istiyorum. Yardımınızı bekliyorum. Teşekkürler.

merhaba
öncelikle A sütundaki isimlerin sonunda boşluk var
aynı uzunlukta veriler olmalıdır.

Sub İstediğin_Verileri_Listele()
Dim c As Range, sat As Long, ilkadres As Variant
Sheets("Sayfa1").Range("F2:G" & Rows.Count).ClearContents
sat = 2
With Sheets("Sayfa1").Range("A:A")
Set c = .Find(Sheets("Sayfa1").Range("D1"), LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
ilkadres = c.Address
Do
Sheets("Sayfa1").Cells(sat, "F") = Sheets("Sayfa1").Cells(c.Row, "A")
Sheets("Sayfa1").Cells(sat, "G") = Sheets("Sayfa1").Cells(c.Row, "B")
sat = sat + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> ilkadres
End If
End With
End Sub

bu kod işinizi görecektir.

 

[Orion1]

Dosyanız ektedir.
Kodlar çalışma sayfasında kod modülündedir.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D1]) Is Nothing Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
Range("F2:G65536").ClearContents
Range("A1:B1").AutoFilter
Range("A1:B1").AutoFilter field:=1, Criteria1:=Range("D1").Value
Range("A1:B1").CurrentRegion.Copy Range("F1")
Range("A1:B1").AutoFilter
Application.ScreenUpdating = False
End Sub

 

[fatihdemirel]

Bu kadar kolay olacağını düşünmemiştim her iki çözüm de işimi gördü teşekkürler

 

[serqet]

Hastayım size varya Evren,Korhan,İhsan

 

[İhsan Tank]

Bu kadar kolay olacağını düşünmemiştim her iki çözüm de işimi gördü teşekkürler

rica ederim
Syn : Evren Hocam'ada Çok Teşekkür ederim gene müthiş bir çözümle çıktı karşımıza. :bravo:

Hastayım size varya Evren,Korhan,İhsan

kırmızı boyalı kişi biraz fazla kopya çekiyor.
paylaştığı kod Syn : Ömer Uzman'a aittir. Kendisine çok teşekkür ederim.
:yazici: