Sütunları 4'er sütun atlayarak ve aralarına virgül ekleyerek birleştirme

[demgüzar]

Merhaba, soruyu doğru yerde mi soruyorum bilemedim. Öğrencilerim için sınav karnesi gibi bir şey hazırlamak niyetindeyim.
b1 hücresinde d1 hücresinden başlayarak 4 sütun atlayıp eğer sütunlarda değer varsa değerlerin aralarına virgül koyarak birleştiren formülü ya da kodu nasıl yazarım?


yani B1 hücresine (sütunlarda değer varsa) D1,H1,L1,P1.....HH1
B2 hücresine (sütunlarda değer varsa) D2,H2,L2,P2..... HH2 şeklinde aralarında virgül ekleyerek birleştirecek.
Çalıştığım aralık B1:HH205

Yardımcı olursanız çok sevinirim. Saygılarımla

 

[ÖmerBey]

Merhaba,
Öncelikle şu kodu boş bir modüle kopyalayınız.

Function ATLABİR(alan As Range, adim As Byte, ayrac As String)
For a = 1 To alan.Cells.Count Step adim
    If alan.Cells(a) <> "" Then
        If ATLABİR = "" Then ATLABİR = alan.Cells(a) Else ATLABİR = ATLABİR & ayrac & alan.Cells(a)
    End If
Next
End Function

Daha sonra herhangi bir hücreye ATLABİR(alan, adim, ayrac) mantığıyla yazabilirsiniz.
Mesela B1 hücresi için formülü şu şekilde kullanabilirsiniz: =ATLABİR(D1:HH1;4;",")

 

[demgüzar]

Ömer Bey, çok teşekkür ederim. Sağ olun, tam istediğim gibi...

 

[demgüzar]

Bu kodu boş hücreleri atlayacak şekilde değil de boş olan hücrede kısa çizgi (-) olacak şekilde nasıl uyarlayabilirim? Çok oluyorsam özür dilerim.

 

[ÖmerBey]

Aşağıdaki kodu deneyiniz. Karakteri değiştirmek isterseniz kırmızı kısmı değiştirin.

Function ATLABİR(alan As Range, adim As Byte, ayrac As String)
Dim deg As String
For a = 1 To alan.Cells.Count Step adim
    deg = IIf(alan.Cells(a) = "", "-", alan.Cells(a))
    ATLABİR = IIf(ATLABİR = "", deg, ATLABİR & ayrac & deg)
Next
End Function

 

[demgüzar]

Allah razı olsun...

 

[ÖmerBey]

Allah hepimizden razı olsun.
İyi geceler, iyi çalışmalar...