alt alta hücreleri aralarında (,) olacak şekilde ve boşluksuz olarak tek bir hücreye alma

[tukayf]

Değerli hocalarım, alt alta yer alan sicillerin aralarına (,) konulacak ve boşluklar kaldırılmış şekilde tek bir hücreye nasıl yazdırabilirim. Makro çözümü de olabilir. ekteki örnekte de açılmaya çalıştım. D sütunundaki sicilleri W1 hücresine virgüllü ve boşluksuz şekilde aldırmak istiyorum. D2:sondolu hücre şeklinde çözüm olursa daha işlevsel olacak. Yanıtlar için şimdiden çok teşekkürler.

 

[Haluk]

Sub Test()
    noD = Range("D" & Rows.Count).End(xlUp).Row
    myStr = Join(Application.Transpose(Range("D2:D" & noD)), ",")
    
    Range("W1").NumberFormat = "@"
    Range("W1") = myStr
End Sub

.

 

[muygun]

Merhaba;
Sayfanın kod bölümüne;

Sub işlem()
Application.ScreenUpdating = False
On Error Resume Next
Cells(1, "w") = ""
For i = 2 To Range("d65536").End(xlUp).Row
If Trim(Cells(i, "d")) <> "" Then
If Cells(1, "w") <> "" Then
Cells(1, "w") = Cells(1, "w") & "," & Trim(Cells(i, "d"))
End If
If Cells(1, "w") = "" Then
Cells(1, "w") = Trim(Cells(i, "d"))
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Ekleyerek deneyin.
İyi çalışmalar.

Not: syn.Haluk çözüm üretmiş. (gönderiyi görmeden yazmıştım)

 

[tukayf]

Değerli hocalarım yanıtlar için çok teşekkürler. Bizim bulduğumuz çözümler epey uzun sürüyordu.